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

import Clckwrks
import Clckwrks.Admin.Route         (routeAdmin)
import Clckwrks.Monad               (ClckwrksConfig(..), TLSSettings(..), calcBaseURI, calcTLSBaseURI, initialClckPluginsSt)
-- import Clckwrks.Page.Acid           (GetPageTitle(..), IsPublishedPage(..))
-- import Clckwrks.Page.Atom           (handleAtomFeed)
-- import Clckwrks.Page.PreProcess     (pageCmd)
import Clckwrks.ProfileData.Types   (Role(..))
import Clckwrks.ProfileData.URL     (ProfileDataURL(..))
import Control.Arrow                (second)
import Control.Concurrent           (forkIO, killThread)
import Control.Concurrent.STM       (atomically, newTVar, readTVar)
import Control.Monad.State          (get, evalStateT)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import Data.Acid.Advanced           (query')
import           Data.Map           (Map)
import qualified Data.Map           as Map
import Data.Maybe                   (fromJust, fromMaybe, isNothing)
import Data.Monoid                  ((<>))
import qualified Data.ByteString.Lazy.UTF8 as UTF8
import Data.ByteString.Builder      (toLazyByteString)
import Data.String                  (fromString)
import           Data.Text          (Text)
import qualified Data.Text          as Text
import Data.Text.Encoding (decodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.UUID.Types    as UUID
import Happstack.Server.FileServe.BuildingBlocks (guessContentTypeM, isSafePath, serveFile)
import Happstack.Server.Internal.Multipart (simpleInput)
import Happstack.Server.Internal.Types (canHaveBody)
import Happstack.Server.Monads      (askRq)
import Happstack.Server.SimpleHTTPS (TLSConf(..), nullTLSConf, simpleHTTPS)
import Happstack.Server.Types       (Request(rqMethod))
import Network.HTTP.Types           (encodePathSegments)
import Network.HTTP.Types.URI       (renderQueryText)
import System.FilePath              ((</>), makeRelative, splitDirectories)
import Web.Routes.Happstack         (implSite)
import Web.Plugins.Core             (Plugins(..), PluginsState(pluginsRewrite), Rewrite(Rewrite, Redirect), withPlugins, getPluginRouteFn, getPostHooks, serve)
import qualified Paths_clckwrks     as Clckwrks

withClckwrks :: ClckwrksConfig -> (ClckState -> IO b) -> IO b
withClckwrks :: ClckwrksConfig -> (ClckState -> IO b) -> IO b
withClckwrks ClckwrksConfig
cc ClckState -> IO b
action = do
  let top' :: Maybe FilePath
top' = (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FilePath
top -> FilePath
top FilePath -> FilePath -> FilePath
</> FilePath
"_state") (ClckwrksConfig -> Maybe FilePath
clckTopDir ClckwrksConfig
cc)
  Maybe FilePath -> (Acid -> IO b) -> IO b
forall a. Maybe FilePath -> (Acid -> IO a) -> IO a
withAcid Maybe FilePath
top' ((Acid -> IO b) -> IO b) -> (Acid -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Acid
acid ->
    ClckwrksConfig
-> ClckPluginsSt
-> (Plugins
      Theme
      (ClckT ClckURL (ServerPartT IO) Response)
      (ClckT ClckURL IO ())
      ClckwrksConfig
      ClckPluginsSt
    -> IO b)
-> IO b
forall config st theme m hook a.
config -> st -> (Plugins theme m hook config st -> IO a) -> IO a
withPlugins ClckwrksConfig
cc (Acid -> ClckPluginsSt
initialClckPluginsSt Acid
acid) ((Plugins
    Theme
    (ClckT ClckURL (ServerPartT IO) Response)
    (ClckT ClckURL IO ())
    ClckwrksConfig
    ClckPluginsSt
  -> IO b)
 -> IO b)
-> (Plugins
      Theme
      (ClckT ClckURL (ServerPartT IO) Response)
      (ClckT ClckURL IO ())
      ClckwrksConfig
      ClckPluginsSt
    -> IO b)
-> IO b
forall a b. (a -> b) -> a -> b
$ \Plugins
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
plugins -> do
      TVar Integer
u <- STM (TVar Integer) -> IO (TVar Integer)
forall a. STM a -> IO a
atomically (STM (TVar Integer) -> IO (TVar Integer))
-> STM (TVar Integer) -> IO (TVar Integer)
forall a b. (a -> b) -> a -> b
$ Integer -> STM (TVar Integer)
forall a. a -> STM (TVar a)
newTVar Integer
0
      let clckState :: ClckState
clckState = ClckState :: Acid
-> TVar Integer
-> [(Text, [(Set Role, Text, Text)])]
-> Bool
-> Plugins
     Theme
     (ClckT ClckURL (ServerPartT IO) Response)
     (ClckT ClckURL IO ())
     ClckwrksConfig
     ClckPluginsSt
-> ServerPart ()
-> ClckState
ClckState { acidState :: Acid
acidState        = Acid
acid
--                                        , currentPage      = PageId 0
                                , uniqueId :: TVar Integer
uniqueId         = TVar Integer
u
                                , adminMenus :: [(Text, [(Set Role, Text, Text)])]
adminMenus       = []
                                , enableAnalytics :: Bool
enableAnalytics  = ClckwrksConfig -> Bool
clckEnableAnalytics ClckwrksConfig
cc
                                , plugins :: Plugins
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
plugins          = Plugins
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
plugins
                                , requestInit :: ServerPart ()
requestInit      = () -> ServerPart ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                }
      ClckState -> IO b
action ClckState
clckState

simpleClckwrks :: ClckwrksConfig -> IO ()
simpleClckwrks :: ClckwrksConfig -> IO ()
simpleClckwrks ClckwrksConfig
cc =
  ClckwrksConfig -> (ClckState -> IO ()) -> IO ()
forall b. ClckwrksConfig -> (ClckState -> IO b) -> IO b
withClckwrks ClckwrksConfig
cc ((ClckState -> IO ()) -> IO ()) -> (ClckState -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ClckState
clckState ->
      do let baseURI :: Text
baseURI =
               case ClckwrksConfig -> Maybe Text
calcTLSBaseURI ClckwrksConfig
cc of
                 (Just Text
baseUri) -> Text
baseUri
                 Maybe Text
Nothing -> ClckwrksConfig -> Text
calcBaseURI ClckwrksConfig
cc
         (ClckState
clckState', ClckwrksConfig
cc') <- (ClckwrksConfig
-> Text
-> ClckState
-> ClckwrksConfig
-> IO (ClckState, ClckwrksConfig)
clckInitHook ClckwrksConfig
cc) Text
baseURI ClckState
clckState ClckwrksConfig
cc
         let p :: Plugins
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
p = ClckState
-> Plugins
     Theme
     (ClckT ClckURL (ServerPartT IO) Response)
     (ClckT ClckURL IO ())
     ClckwrksConfig
     ClckPluginsSt
plugins ClckState
clckState'
         [ClckT ClckURL IO ()]
hooks <- Plugins
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
-> IO [ClckT ClckURL IO ()]
forall (m :: * -> *) theme n hook config st.
MonadIO m =>
Plugins theme n hook config st -> m [hook]
getPostHooks Plugins
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
p
         ~(Just ClckURL -> [(Text, Maybe Text)] -> Text
clckShowFn) <- Plugins
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
-> Text -> IO (Maybe (ClckURL -> [(Text, Maybe Text)] -> Text))
forall (m :: * -> *) url theme n hook config st.
(MonadIO m, Typeable url) =>
Plugins theme n hook config st
-> Text -> m (Maybe (url -> [(Text, Maybe Text)] -> Text))
getPluginRouteFn Plugins
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
p Text
"clck"
         let showFn :: ClckURL -> p -> Text
showFn = \ClckURL
url p
params -> ClckURL -> [(Text, Maybe Text)] -> Text
clckShowFn ClckURL
url []
         ClckState
clckState'' <- (ClckURL -> [(Text, Maybe Text)] -> Text)
-> ClckState -> ClckT ClckURL IO () -> IO ClckState
forall (m :: * -> *) url a.
Monad m =>
(url -> [(Text, Maybe Text)] -> Text)
-> ClckState -> ClckT url m a -> m ClckState
execClckT ClckURL -> [(Text, Maybe Text)] -> Text
forall p. ClckURL -> p -> Text
showFn ClckState
clckState' (ClckT ClckURL IO () -> IO ClckState)
-> ClckT ClckURL IO () -> IO ClckState
forall a b. (a -> b) -> a -> b
$ [ClckT ClckURL IO ()] -> ClckT ClckURL IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ClckT ClckURL IO ()]
hooks

         Maybe ThreadId
mHttpsTID <-
             case ClckwrksConfig -> Maybe TLSSettings
clckTLS ClckwrksConfig
cc' of
               Maybe TLSSettings
Nothing -> Maybe ThreadId -> IO (Maybe ThreadId)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ThreadId
forall a. Maybe a
Nothing
               (Just TLSSettings{Int
FilePath
Maybe FilePath
clckTLSCA :: TLSSettings -> Maybe FilePath
clckTLSKey :: TLSSettings -> FilePath
clckTLSCert :: TLSSettings -> FilePath
clckTLSPort :: TLSSettings -> Int
clckTLSCA :: Maybe FilePath
clckTLSKey :: FilePath
clckTLSCert :: FilePath
clckTLSPort :: Int
..}) ->
                   do let tlsConf :: TLSConf
tlsConf = TLSConf
nullTLSConf { tlsPort :: Int
tlsPort = Int
clckTLSPort
                                                , tlsCert :: FilePath
tlsCert = FilePath
clckTLSCert
                                                , tlsKey :: FilePath
tlsKey  = FilePath
clckTLSKey
                                                , tlsCA :: Maybe FilePath
tlsCA   = Maybe FilePath
clckTLSCA
                                                }
                      ThreadId
tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ TLSConf -> ServerPartT IO Response -> IO ()
forall a. ToMessage a => TLSConf -> ServerPartT IO a -> IO ()
simpleHTTPS TLSConf
tlsConf (ClckwrksConfig -> ClckState -> ServerPartT IO Response
handlers ClckwrksConfig
cc' ClckState
clckState'')
                      Maybe ThreadId -> IO (Maybe ThreadId)
forall (m :: * -> *) a. Monad m => a -> m a
return (ThreadId -> Maybe ThreadId
forall a. a -> Maybe a
Just ThreadId
tid)

         ThreadId
httpTID  <- if Maybe ThreadId -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ThreadId
mHttpsTID
                       then IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Conf -> ServerPartT IO Response -> IO ()
forall a. ToMessage a => Conf -> ServerPartT IO a -> IO ()
simpleHTTP (Conf
nullConf { port :: Int
port = ClckwrksConfig -> Int
clckPort ClckwrksConfig
cc' }) (ClckwrksConfig -> ClckState -> ServerPartT IO Response
handlers ClckwrksConfig
cc' ClckState
clckState'')
                       else IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Conf -> ServerPartT IO Response -> IO ()
forall a. ToMessage a => Conf -> ServerPartT IO a -> IO ()
simpleHTTP (Conf
nullConf { port :: Int
port = ClckwrksConfig -> Int
clckPort ClckwrksConfig
cc' }) ServerPartT IO Response
forceHTTPS
         -- putStrLn "Server Now Listening For Requests."
         IO ()
waitForTermination
         ThreadId -> IO ()
killThread ThreadId
httpTID
         IO () -> (ThreadId -> IO ()) -> Maybe ThreadId -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ThreadId -> IO ()
killThread Maybe ThreadId
mHttpsTID

    where
      handlers :: ClckwrksConfig -> ClckState -> ServerPart Response
      handlers :: ClckwrksConfig -> ClckState -> ServerPartT IO Response
handlers ClckwrksConfig
cc ClckState
clckState =
       do ServerPart ()
forceCanonicalHost
          Request
req <- ServerPartT IO Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
          Bool -> ServerPart () -> ServerPart ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Method -> Bool
canHaveBody (Request -> Method
rqMethod Request
req)) (ServerPart () -> ServerPart ()) -> ServerPart () -> ServerPart ()
forall a b. (a -> b) -> a -> b
$
            do (FilePath
p, Int64
mDisk, Int64
mRam, Int64
mHeader) <- AcidState (EventState GetBodyPolicy)
-> GetBodyPolicy -> ServerPartT IO (EventResult GetBodyPolicy)
forall event (m :: * -> *).
(QueryEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
query' (Acid -> AcidState CoreState
acidCore (Acid -> AcidState CoreState) -> Acid -> AcidState CoreState
forall a b. (a -> b) -> a -> b
$ ClckState -> Acid
acidState ClckState
clckState) GetBodyPolicy
GetBodyPolicy
               BodyPolicy -> ServerPart ()
forall (m :: * -> *).
(ServerMonad m, MonadPlus m, MonadIO m, FilterMonad Response m,
 WebMonad Response m) =>
BodyPolicy -> m ()
decodeBody (FilePath -> Int64 -> Int64 -> Int64 -> BodyPolicy
defaultBodyPolicy FilePath
p Int64
mDisk Int64
mRam Int64
mHeader)
          ClckState -> ServerPart ()
requestInit ClckState
clckState
          [ServerPartT IO Response] -> ServerPartT IO Response
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([ServerPartT IO Response] -> ServerPartT IO Response)
-> [ServerPartT IO Response] -> ServerPartT IO Response
forall a b. (a -> b) -> a -> b
$
            [ ClckwrksConfig -> ServerPartT IO Response
forall (m :: * -> *). Happstack m => ClckwrksConfig -> m Response
jsHandlers ClckwrksConfig
cc
            , FilePath -> ServerPartT IO Response -> ServerPartT IO Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
FilePath -> m a -> m a
dir FilePath
"static"      (ServerPartT IO Response -> ServerPartT IO Response)
-> ServerPartT IO Response -> ServerPartT IO Response
forall a b. (a -> b) -> a -> b
$ (IO FilePath -> ServerPartT IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> ServerPartT IO FilePath)
-> IO FilePath -> ServerPartT IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
Clckwrks.getDataFileName FilePath
"static") ServerPartT IO FilePath
-> (FilePath -> ServerPartT IO Response) -> ServerPartT IO Response
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Browsing -> [FilePath] -> FilePath -> ServerPartT IO Response
forall (m :: * -> *).
(WebMonad Response m, ServerMonad m, FilterMonad Response m,
 MonadIO m, MonadPlus m) =>
Browsing -> [FilePath] -> FilePath -> m Response
serveDirectory Browsing
DisableBrowsing []
            , do ServerPart ()
forall (m :: * -> *). (ServerMonad m, MonadPlus m) => m ()
nullDir
                 Maybe Text
mRR <- AcidState (EventState GetRootRedirect)
-> GetRootRedirect -> ServerPartT IO (EventResult GetRootRedirect)
forall event (m :: * -> *).
(QueryEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
query' (Acid -> AcidState CoreState
acidCore (Acid -> AcidState CoreState)
-> (ClckState -> Acid) -> ClckState -> AcidState CoreState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClckState -> Acid
acidState (ClckState -> AcidState CoreState)
-> ClckState -> AcidState CoreState
forall a b. (a -> b) -> a -> b
$ ClckState
clckState) GetRootRedirect
GetRootRedirect
                 Text -> Response -> ServerPartT IO Response
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (Text
"/page/view-page/1") Maybe Text
mRR) (() -> Response
forall a. ToMessage a => a -> Response
toResponse ()) -- FIXME: get redirect location from database
            , ClckwrksConfig -> ClckState -> ServerPartT IO Response
clckSite ClckwrksConfig
cc ClckState
clckState
            ]

      forceCanonicalHost :: ServerPart ()
      forceCanonicalHost :: ServerPart ()
forceCanonicalHost =
          do Request
rq <- ServerPartT IO Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
             case FilePath -> Request -> Maybe ByteString
forall r. HasHeaders r => FilePath -> r -> Maybe ByteString
getHeader FilePath
"host" Request
rq of
               Maybe ByteString
Nothing -> () -> ServerPart ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
               (Just ByteString
hostBS) ->
                   if (ClckwrksConfig -> FilePath
clckHostname ClckwrksConfig
cc FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== (ByteString -> FilePath
B.unpack (ByteString -> FilePath) -> ByteString -> FilePath
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
B.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') ByteString
hostBS))
                   then () -> ServerPart ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   else ServerPartT IO Response -> ServerPart ()
forall a (m :: * -> *) b.
(WebMonad a m, FilterMonad a m) =>
m a -> m b
escape (ServerPartT IO Response -> ServerPart ())
-> ServerPartT IO Response -> ServerPart ()
forall a b. (a -> b) -> a -> b
$ Text -> Response -> ServerPartT IO Response
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther ((if Request -> Bool
rqSecure Request
rq then (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ ClckwrksConfig -> Maybe Text
calcTLSBaseURI ClckwrksConfig
cc) else (ClckwrksConfig -> Text
calcBaseURI ClckwrksConfig
cc)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (FilePath -> Text
Text.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Request -> FilePath
rqUri Request
rq) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (FilePath -> Text
Text.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Request -> FilePath
rqQuery Request
rq)) (() -> Response
forall a. ToMessage a => a -> Response
toResponse ())

      -- if https:// is available, then force it to be used.
      -- GET requests will be redirected automatically, POST, PUT, etc will be denied
      forceHTTPS :: ServerPart Response
      forceHTTPS :: ServerPartT IO Response
forceHTTPS =
          [ServerPartT IO Response] -> ServerPartT IO Response
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [ do Method -> ServerPart ()
forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
GET
                    Request
rq <- ServerPartT IO Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
                    Text -> Response -> ServerPartT IO Response
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther ((Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ ClckwrksConfig -> Maybe Text
calcTLSBaseURI ClckwrksConfig
cc) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (FilePath -> Text
Text.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Request -> FilePath
rqUri Request
rq) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (FilePath -> Text
Text.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Request -> FilePath
rqQuery Request
rq)) (() -> Response
forall a. ToMessage a => a -> Response
toResponse ())
               , do Response -> ServerPartT IO Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
forbidden (Text -> Response
forall a. ToMessage a => a -> Response
toResponse (Text
"https:// required." :: Text))
               ]

jsHandlers :: (Happstack m) => ClckwrksConfig -> m Response
jsHandlers :: ClckwrksConfig -> m Response
jsHandlers ClckwrksConfig
c =
  [m Response] -> m Response
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [ FilePath -> m Response -> m Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
FilePath -> m a -> m a
dir FilePath
"jquery"      (m Response -> m Response) -> m Response -> m Response
forall a b. (a -> b) -> a -> b
$ Browsing -> [FilePath] -> FilePath -> m Response
forall (m :: * -> *).
(WebMonad Response m, ServerMonad m, FilterMonad Response m,
 MonadIO m, MonadPlus m) =>
Browsing -> [FilePath] -> FilePath -> m Response
serveDirectory Browsing
DisableBrowsing [] (ClckwrksConfig -> FilePath
clckJQueryPath ClckwrksConfig
c)
       , FilePath -> m Response -> m Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
FilePath -> m a -> m a
dir FilePath
"jquery-ui"   (m Response -> m Response) -> m Response -> m Response
forall a b. (a -> b) -> a -> b
$ Browsing -> [FilePath] -> FilePath -> m Response
forall (m :: * -> *).
(WebMonad Response m, ServerMonad m, FilterMonad Response m,
 MonadIO m, MonadPlus m) =>
Browsing -> [FilePath] -> FilePath -> m Response
serveDirectory Browsing
DisableBrowsing [] (ClckwrksConfig -> FilePath
clckJQueryUIPath ClckwrksConfig
c)
       , FilePath -> m Response -> m Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
FilePath -> m a -> m a
dir FilePath
"jstree"      (m Response -> m Response) -> m Response -> m Response
forall a b. (a -> b) -> a -> b
$ Browsing -> [FilePath] -> FilePath -> m Response
forall (m :: * -> *).
(WebMonad Response m, ServerMonad m, FilterMonad Response m,
 MonadIO m, MonadPlus m) =>
Browsing -> [FilePath] -> FilePath -> m Response
serveDirectory Browsing
DisableBrowsing [] (ClckwrksConfig -> FilePath
clckJSTreePath ClckwrksConfig
c)
       , FilePath -> m Response -> m Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
FilePath -> m a -> m a
dir FilePath
"json2"       (m Response -> m Response) -> m Response -> m Response
forall a b. (a -> b) -> a -> b
$ Browsing -> [FilePath] -> FilePath -> m Response
forall (m :: * -> *).
(WebMonad Response m, ServerMonad m, FilterMonad Response m,
 MonadIO m, MonadPlus m) =>
Browsing -> [FilePath] -> FilePath -> m Response
serveDirectory Browsing
DisableBrowsing [] (ClckwrksConfig -> FilePath
clckJSON2Path ClckwrksConfig
c)
       ]

clckSite :: ClckwrksConfig -> ClckState -> ServerPart Response
clckSite :: ClckwrksConfig -> ClckState -> ServerPartT IO Response
clckSite ClckwrksConfig
cc ClckState
clckState =
    do ~(Just ClckURL -> [(Text, Maybe Text)] -> Text
clckShowFn) <- Plugins
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
-> Text
-> ServerPartT IO (Maybe (ClckURL -> [(Text, Maybe Text)] -> Text))
forall (m :: * -> *) url theme n hook config st.
(MonadIO m, Typeable url) =>
Plugins theme n hook config st
-> Text -> m (Maybe (url -> [(Text, Maybe Text)] -> Text))
getPluginRouteFn (ClckState
-> Plugins
     Theme
     (ClckT ClckURL (ServerPartT IO) Response)
     (ClckT ClckURL IO ())
     ClckwrksConfig
     ClckPluginsSt
plugins ClckState
clckState) (FilePath -> Text
Text.pack FilePath
"clck")
       (ClckURL -> [(Text, Maybe Text)] -> Text)
-> ClckState
-> ClckT ClckURL (ServerPartT IO) Response
-> ServerPartT IO Response
forall (m :: * -> *) url a.
Monad m =>
(url -> [(Text, Maybe Text)] -> Text)
-> ClckState -> ClckT url m a -> m a
evalClckT ClckURL -> [(Text, Maybe Text)] -> Text
clckShowFn ClckState
clckState (ClckwrksConfig
-> Plugins
     Theme
     (ClckT ClckURL (ServerPartT IO) Response)
     (ClckT ClckURL IO ())
     ClckwrksConfig
     ClckPluginsSt
-> ClckT ClckURL (ServerPartT IO) Response
forall (m :: * -> *) theme hook config ppm.
(Functor m, Happstack m, MonadIO m) =>
ClckwrksConfig
-> Plugins theme (m Response) hook config ppm -> m Response
pluginsHandler ClckwrksConfig
cc (ClckState
-> Plugins
     Theme
     (ClckT ClckURL (ServerPartT IO) Response)
     (ClckT ClckURL IO ())
     ClckwrksConfig
     ClckPluginsSt
plugins ClckState
clckState))

pluginsHandler :: (Functor m, Happstack m, MonadIO m) =>
                  ClckwrksConfig
               -> Plugins theme (m Response) hook config ppm
            -> m Response
pluginsHandler :: ClckwrksConfig
-> Plugins theme (m Response) hook config ppm -> m Response
pluginsHandler ClckwrksConfig
cc plugins :: Plugins theme (m Response) hook config ppm
plugins@(Plugins TVar (PluginsState theme (m Response) hook config ppm)
tvp) =
    do PluginsState theme (m Response) hook config ppm
ps' <- IO (PluginsState theme (m Response) hook config ppm)
-> m (PluginsState theme (m Response) hook config ppm)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (PluginsState theme (m Response) hook config ppm)
 -> m (PluginsState theme (m Response) hook config ppm))
-> IO (PluginsState theme (m Response) hook config ppm)
-> m (PluginsState theme (m Response) hook config ppm)
forall a b. (a -> b) -> a -> b
$ STM (PluginsState theme (m Response) hook config ppm)
-> IO (PluginsState theme (m Response) hook config ppm)
forall a. STM a -> IO a
atomically (STM (PluginsState theme (m Response) hook config ppm)
 -> IO (PluginsState theme (m Response) hook config ppm))
-> STM (PluginsState theme (m Response) hook config ppm)
-> IO (PluginsState theme (m Response) hook config ppm)
forall a b. (a -> b) -> a -> b
$ TVar (PluginsState theme (m Response) hook config ppm)
-> STM (PluginsState theme (m Response) hook config ppm)
forall a. TVar a -> STM a
readTVar TVar (PluginsState theme (m Response) hook config ppm)
tvp
       Request
req <- m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
       let paths' :: [Text]
paths' = (FilePath -> Text) -> [FilePath] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Text
Text.pack ([FilePath] -> [Text]) -> [FilePath] -> [Text]
forall a b. (a -> b) -> a -> b
$ Request -> [FilePath]
rqPaths Request
req
           params' :: [(Text, Maybe Text)]
params'=
             let conv :: (String, Input) -> (Text, Maybe Text)
                 conv :: (FilePath, Input) -> (Text, Maybe Text)
conv (FilePath
k, Input
i) =
                   case Input -> Either FilePath ByteString
inputValue Input
i of
                     (Left FilePath
_)   -> (FilePath -> Text
Text.pack FilePath
k, Maybe Text
forall a. Maybe a
Nothing)
                     (Right ByteString
bs) -> (FilePath -> Text
Text.pack FilePath
k, Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> ByteString
LB.toStrict ByteString
bs))
             in ((FilePath, Input) -> (Text, Maybe Text))
-> [(FilePath, Input)] -> [(Text, Maybe Text)]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, Input) -> (Text, Maybe Text)
conv (Request -> [(FilePath, Input)]
rqInputsQuery Request
req)
       -- we figure out which plugin to call by looking at the
       -- first path segment in the url
       let cont :: [Text] -> m Response
cont [Text]
paths =
             case [Text]
paths of
               (Text
p : [Text]
ps) ->
                 do Either FilePath (m Response)
e <- IO (Either FilePath (m Response))
-> m (Either FilePath (m Response))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either FilePath (m Response))
 -> m (Either FilePath (m Response)))
-> IO (Either FilePath (m Response))
-> m (Either FilePath (m Response))
forall a b. (a -> b) -> a -> b
$ Plugins theme (m Response) hook config ppm
-> Text -> [Text] -> IO (Either FilePath (m Response))
forall theme n hook config st.
Plugins theme n hook config st
-> Text -> [Text] -> IO (Either FilePath n)
serve Plugins theme (m Response) hook config ppm
plugins Text
p [Text]
ps
                    case Either FilePath (m Response)
e of
                      (Right m Response
c) -> m Response
c
                      (Left FilePath
e) -> Response -> m Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
notFound (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$ FilePath -> Response
forall a. ToMessage a => a -> Response
toResponse FilePath
e
               [Text]
_ -> Response -> m Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
notFound (() -> Response
forall a. ToMessage a => a -> Response
toResponse ())

       -- before we can figure out what the path segment is, we
       -- need to rewrite the URL.
       -- FIXME: Somewhat annoyingly, we rewrite the url and then
       -- throw out the results.
       case PluginsState theme (m Response) hook config ppm
-> Maybe (RewriteIncoming, RewriteOutgoing)
forall theme n hook config st.
PluginsState theme n hook config st
-> Maybe (RewriteIncoming, RewriteOutgoing)
pluginsRewrite PluginsState theme (m Response) hook config ppm
ps' of
         Maybe (RewriteIncoming, RewriteOutgoing)
Nothing  -> [Text] -> m Response
cont [Text]
paths'
         (Just (RewriteIncoming
mf, RewriteOutgoing
_)) ->
           let conv :: (Text, Maybe Text) -> (String, Input)
               conv :: (Text, Maybe Text) -> (FilePath, Input)
conv (Text
k, Maybe Text
v) = (Text -> FilePath
Text.unpack Text
k, Input -> (Text -> Input) -> Maybe Text -> Input
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> Input
simpleInput FilePath
"") (\Text
v' -> FilePath -> Input
simpleInput (FilePath -> Input) -> FilePath -> Input
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
Text.unpack Text
v') Maybe Text
v)
           in do [Text]
-> [(Text, Maybe Text)]
-> Maybe (Rewrite, [Text], [(Text, Maybe Text)])
f <- RewriteIncoming
-> m ([Text]
      -> [(Text, Maybe Text)]
      -> Maybe (Rewrite, [Text], [(Text, Maybe Text)]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO RewriteIncoming
mf
                 case [Text]
-> [(Text, Maybe Text)]
-> Maybe (Rewrite, [Text], [(Text, Maybe Text)])
f [Text]
paths' [(Text, Maybe Text)]
params' of
                   (Just (Rewrite
Rewrite, [Text]
paths, [(Text, Maybe Text)]
params))  ->
                     let qry :: Text
qry = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LB.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Bool -> [(Text, Maybe Text)] -> Builder
renderQueryText Bool
True [(Text, Maybe Text)]
params
                         pi :: Text
pi  = (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LB.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [Text] -> Builder
encodePathSegments [Text]
paths)
                     in
                       (Request -> Request) -> m Response -> m Response
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq (\Request
req -> Request
req { rqQuery :: FilePath
rqQuery       = ByteString -> FilePath
UTF8.toString (ByteString -> FilePath) -> ByteString -> FilePath
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Bool -> [(Text, Maybe Text)] -> Builder
renderQueryText Bool
True [(Text, Maybe Text)]
params
                                            , rqPaths :: [FilePath]
rqPaths       = (Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
Text.unpack [Text]
paths
                                            , rqUri :: FilePath
rqUri         = Text -> FilePath
Text.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ (if Request -> Bool
rqSecure Request
req then (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ ClckwrksConfig -> Maybe Text
calcTLSBaseURI ClckwrksConfig
cc) else (ClckwrksConfig -> Text
calcBaseURI ClckwrksConfig
cc)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
qry
                                            , rqInputsQuery :: [(FilePath, Input)]
rqInputsQuery = ((Text, Maybe Text) -> (FilePath, Input))
-> [(Text, Maybe Text)] -> [(FilePath, Input)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Maybe Text) -> (FilePath, Input)
conv [(Text, Maybe Text)]
params
                                            }) (m Response -> m Response) -> m Response -> m Response
forall a b. (a -> b) -> a -> b
$ do -- rq <- askRq
                                                    -- liftIO $ print rq
                                                    [Text] -> m Response
cont [Text]
paths
                   (Just (Redirect Maybe Text
mBaseURI, [Text]
paths, [(Text, Maybe Text)]
params))  ->
                     let qry :: Text
qry = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LB.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Bool -> [(Text, Maybe Text)] -> Builder
renderQueryText Bool
True [(Text, Maybe Text)]
params
                         pi :: Text
pi  = (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LB.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [Text] -> Builder
encodePathSegments [Text]
paths)
                     in
                       do -- liftIO $ putStrLn $ show $ rqQuery req
                          m Response -> m Response
forall a (m :: * -> *) b.
(WebMonad a m, FilterMonad a m) =>
m a -> m b
escape (m Response -> m Response) -> m Response -> m Response
forall a b. (a -> b) -> a -> b
$ Text -> Response -> m Response
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther ((Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (if Request -> Bool
rqSecure Request
req then (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ ClckwrksConfig -> Maybe Text
calcTLSBaseURI ClckwrksConfig
cc) else (ClckwrksConfig -> Text
calcBaseURI ClckwrksConfig
cc)) Maybe Text
mBaseURI) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
qry) (() -> Response
forall a. ToMessage a => a -> Response
toResponse ())
                   Maybe (Rewrite, [Text], [(Text, Maybe Text)])
Nothing -> [Text] -> m Response
cont [Text]
paths'

--                (Redirect, paths) -> seeOther