{-# LANGUAGE FlexibleContexts, RecordWildCards, OverloadedStrings #-}
module Clckwrks.Route where

import Clckwrks
import Clckwrks.Acid               (GetEnableOpenId(..))
import Clckwrks.Admin.Route        (routeAdmin)
import Clckwrks.BasicTemplate      (basicTemplate)
import Clckwrks.Monad              (calcTLSBaseURI, withAbs, query)
import Clckwrks.ProfileData.API    (requiresRole)
import Clckwrks.ProfileData.Route  (routeProfileData)
import Clckwrks.JS.Route           (routeJS)
import Control.Monad.State         (MonadState(get))
import Data.Maybe                  (fromJust)
import Data.Monoid                 ((<>))
import qualified Data.Set          as Set
import Data.Text                   (Text, pack)
import qualified Data.Text         as Text
import Happstack.Server.FileServe.BuildingBlocks (guessContentTypeM, isSafePath, serveFile)
import Network.URI                 (unEscapeString)
import Paths_clckwrks              (getDataDir)
import System.FilePath             ((</>), makeRelative, splitDirectories)
import Web.Plugins.Core            (Plugin(..), addHandler, getConfig, getTheme, getPluginRouteFn, initPlugin)

checkAuth :: (Happstack m, Monad m) =>
             ClckURL
          -> ClckT ClckURL m ClckURL
checkAuth :: ClckURL -> ClckT ClckURL m ClckURL
checkAuth ClckURL
url =
    case ClckURL
url of
      ThemeData{}          -> ClckURL -> ClckT ClckURL m ClckURL
forall (m :: * -> *) a. Monad m => a -> m a
return ClckURL
url
      ThemeDataNoEscape{}  -> ClckURL -> ClckT ClckURL m ClckURL
forall (m :: * -> *) a. Monad m => a -> m a
return ClckURL
url
      PluginData{}         -> ClckURL -> ClckT ClckURL m ClckURL
forall (m :: * -> *) a. Monad m => a -> m a
return ClckURL
url
      Admin{}              -> Set Role -> ClckURL -> ClckT ClckURL m ClckURL
forall (m :: * -> *) url.
Happstack m =>
Set Role -> url -> ClckT ClckURL m url
requiresRole (Role -> Set Role
forall a. a -> Set a
Set.singleton Role
Administrator) ClckURL
url
      JS   {}              -> ClckURL -> ClckT ClckURL m ClckURL
forall (m :: * -> *) a. Monad m => a -> m a
return ClckURL
url
      Profile EditProfileData{}    -> Set Role -> ClckURL -> ClckT ClckURL m ClckURL
forall (m :: * -> *) url.
Happstack m =>
Set Role -> url -> ClckT ClckURL m url
requiresRole ([Role] -> Set Role
forall a. Ord a => [a] -> Set a
Set.fromList [Role
Administrator, Role
Visitor]) ClckURL
url
      Profile EditNewProfileData{} -> Set Role -> ClckURL -> ClckT ClckURL m ClckURL
forall (m :: * -> *) url.
Happstack m =>
Set Role -> url -> ClckT ClckURL m url
requiresRole ([Role] -> Set Role
forall a. Ord a => [a] -> Set a
Set.fromList [Role
Administrator, Role
Visitor]) ClckURL
url
      Profile EditProfileDataFor{} -> Set Role -> ClckURL -> ClckT ClckURL m ClckURL
forall (m :: * -> *) url.
Happstack m =>
Set Role -> url -> ClckT ClckURL m url
requiresRole ([Role] -> Set Role
forall a. Ord a => [a] -> Set a
Set.fromList [Role
Administrator]) ClckURL
url
      Profile ProfileDataURL
CreateNewProfileData -> ClckURL -> ClckT ClckURL m ClckURL
forall (m :: * -> *) a. Monad m => a -> m a
return ClckURL
url

routeClck :: ClckURL
          -> Clck ClckURL Response
routeClck :: ClckURL -> Clck ClckURL Response
routeClck ClckURL
url' =
    do ClckURL
url <- ClckURL -> ClckT ClckURL (ServerPartT IO) ClckURL
forall (m :: * -> *).
(Happstack m, Monad m) =>
ClckURL -> ClckT ClckURL m ClckURL
checkAuth ClckURL
url'
       Integer -> ClckT ClckURL (ServerPartT IO) ()
forall (m :: * -> *) url.
(Functor m, MonadIO m) =>
Integer -> ClckT url m ()
setUnique Integer
0
       case ClckURL
url of
         (ThemeData String
fp')  ->
             do ClckPlugins
p      <- ClckState -> ClckPlugins
plugins (ClckState -> ClckPlugins)
-> ClckT ClckURL (ServerPartT IO) ClckState
-> ClckT ClckURL (ServerPartT IO) ClckPlugins
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT ClckURL (ServerPartT IO) ClckState
forall s (m :: * -> *). MonadState s m => m s
get
                Maybe Theme
mTheme <- ClckPlugins -> ClckT ClckURL (ServerPartT IO) (Maybe Theme)
forall (m :: * -> *) theme n hook config st.
MonadIO m =>
Plugins theme n hook config st -> m (Maybe theme)
getTheme ClckPlugins
p
                case Maybe Theme
mTheme of
                  Maybe Theme
Nothing -> Response -> Clck ClckURL Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
notFound (Response -> Clck ClckURL Response)
-> Response -> Clck ClckURL Response
forall a b. (a -> b) -> a -> b
$ Text -> Response
forall a. ToMessage a => a -> Response
toResponse (Text
"No theme package is loaded." :: Text)
                  (Just Theme
theme) ->
                      do String
fp    <- IO String -> ClckT ClckURL (ServerPartT IO) String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ClckT ClckURL (ServerPartT IO) String)
-> IO String -> ClckT ClckURL (ServerPartT IO) String
forall a b. (a -> b) -> a -> b
$ Theme -> IO String
themeDataDir Theme
theme
                         let fp'' :: String
fp'' = String -> String -> String
makeRelative String
"/" (String -> String
unEscapeString String
fp')
                         if Bool -> Bool
not ([String] -> Bool
isSafePath (String -> [String]
splitDirectories String
fp''))
                           then Response -> Clck ClckURL Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
notFound (() -> Response
forall a. ToMessage a => a -> Response
toResponse ())
                           else (String -> ClckT ClckURL (ServerPartT IO) String)
-> String -> Clck ClckURL Response
forall (m :: * -> *).
(ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) =>
(String -> m String) -> String -> m Response
serveFile (MimeMap -> String -> ClckT ClckURL (ServerPartT IO) String
forall (m :: * -> *). Monad m => MimeMap -> String -> m String
guessContentTypeM MimeMap
mimeTypes) (String
fp String -> String -> String
</> String
fp'')

         (ThemeDataNoEscape (NoEscape String
fp'))  ->
             do ClckPlugins
p      <- ClckState -> ClckPlugins
plugins (ClckState -> ClckPlugins)
-> ClckT ClckURL (ServerPartT IO) ClckState
-> ClckT ClckURL (ServerPartT IO) ClckPlugins
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT ClckURL (ServerPartT IO) ClckState
forall s (m :: * -> *). MonadState s m => m s
get
                Maybe Theme
mTheme <- ClckPlugins -> ClckT ClckURL (ServerPartT IO) (Maybe Theme)
forall (m :: * -> *) theme n hook config st.
MonadIO m =>
Plugins theme n hook config st -> m (Maybe theme)
getTheme ClckPlugins
p
                case Maybe Theme
mTheme of
                  Maybe Theme
Nothing -> Response -> Clck ClckURL Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
notFound (Response -> Clck ClckURL Response)
-> Response -> Clck ClckURL Response
forall a b. (a -> b) -> a -> b
$ Text -> Response
forall a. ToMessage a => a -> Response
toResponse (Text
"No theme package is loaded." :: Text)
                  (Just Theme
theme) ->
                      do String
fp    <- IO String -> ClckT ClckURL (ServerPartT IO) String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ClckT ClckURL (ServerPartT IO) String)
-> IO String -> ClckT ClckURL (ServerPartT IO) String
forall a b. (a -> b) -> a -> b
$ Theme -> IO String
themeDataDir Theme
theme
                         let fp'' :: String
fp'' = String -> String -> String
makeRelative String
"/" String
fp'
                         if Bool -> Bool
not ([String] -> Bool
isSafePath (String -> [String]
splitDirectories String
fp''))
                           then Response -> Clck ClckURL Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
notFound (() -> Response
forall a. ToMessage a => a -> Response
toResponse ())
                           else (String -> ClckT ClckURL (ServerPartT IO) String)
-> String -> Clck ClckURL Response
forall (m :: * -> *).
(ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) =>
(String -> m String) -> String -> m Response
serveFile (MimeMap -> String -> ClckT ClckURL (ServerPartT IO) String
forall (m :: * -> *). Monad m => MimeMap -> String -> m String
guessContentTypeM MimeMap
mimeTypes) (String
fp String -> String -> String
</> String
fp'')

         (PluginData Text
plugin String
fp')  ->
             do String
pp <- IO String -> ClckT ClckURL (ServerPartT IO) String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getDataDir
                let fp'' :: String
fp'' = String -> String -> String
makeRelative String
"/" (String -> String
unEscapeString String
fp')
                if Bool -> Bool
not ([String] -> Bool
isSafePath (String -> [String]
splitDirectories String
fp''))
                  then Response -> Clck ClckURL Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
notFound (() -> Response
forall a. ToMessage a => a -> Response
toResponse ())
                  else (String -> ClckT ClckURL (ServerPartT IO) String)
-> String -> Clck ClckURL Response
forall (m :: * -> *).
(ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) =>
(String -> m String) -> String -> m Response
serveFile (MimeMap -> String -> ClckT ClckURL (ServerPartT IO) String
forall (m :: * -> *). Monad m => MimeMap -> String -> m String
guessContentTypeM MimeMap
mimeTypes) (String
pp String -> String -> String
</> String
"data" String -> String -> String
</> String
fp'')

         (Admin AdminURL
adminURL) ->
             AdminURL -> Clck ClckURL Response
routeAdmin AdminURL
adminURL

         (Profile ProfileDataURL
profileDataURL) ->
             do (ProfileDataURL -> ClckURL)
-> ClckT ProfileDataURL (ServerPartT IO) Response
-> Clck ClckURL Response
forall url1 url2 (m :: * -> *) a.
(url1 -> url2) -> ClckT url1 m a -> ClckT url2 m a
nestURL ProfileDataURL -> ClckURL
Profile (ClckT ProfileDataURL (ServerPartT IO) Response
 -> Clck ClckURL Response)
-> ClckT ProfileDataURL (ServerPartT IO) Response
-> Clck ClckURL Response
forall a b. (a -> b) -> a -> b
$ ProfileDataURL -> ClckT ProfileDataURL (ServerPartT IO) Response
routeProfileData ProfileDataURL
profileDataURL

         (JS JSURL
jsURL) ->
             do Bool
b <- GetEnableOpenId
-> ClckT ClckURL (ServerPartT IO) (EventResult GetEnableOpenId)
forall event (m :: * -> *).
(QueryEvent event, GetAcidState m (EventState event), Functor m,
 MonadIO m, MonadState ClckState m) =>
event -> m (EventResult event)
query GetEnableOpenId
GetEnableOpenId
                (JSURL -> ClckURL)
-> ClckT JSURL (ServerPartT IO) Response -> Clck ClckURL Response
forall url1 url2 (m :: * -> *) a.
(url1 -> url2) -> ClckT url1 m a -> ClckT url2 m a
nestURL JSURL -> ClckURL
JS (ClckT JSURL (ServerPartT IO) Response -> Clck ClckURL Response)
-> ClckT JSURL (ServerPartT IO) Response -> Clck ClckURL Response
forall a b. (a -> b) -> a -> b
$ Bool -> JSURL -> ClckT JSURL (ServerPartT IO) Response
forall (m :: * -> *) u.
Happstack m =>
Bool -> JSURL -> ClckT u m Response
routeJS Bool
b JSURL
jsURL