clckwrks-0.25.0: Clckwrks/Server.hs

{-# 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)
import Control.Monad.State          (get, evalStateT)
import qualified Data.ByteString.Char8 as B
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 Data.String                  (fromString)
import           Data.Text          (Text)
import qualified Data.Text          as Text
import qualified Data.UUID.Types    as UUID
import Happstack.Server.FileServe.BuildingBlocks (guessContentTypeM, isSafePath, serveFile)
import Happstack.Server.SimpleHTTPS (TLSConf(..), nullTLSConf, simpleHTTPS)
import System.FilePath              ((</>), makeRelative, splitDirectories)
import Web.Routes.Happstack         (implSite)
import Web.Plugins.Core             (Plugins, withPlugins, getPluginRouteFn, getPostHooks, serve)
import qualified Paths_clckwrks     as Clckwrks

withClckwrks :: ClckwrksConfig -> (ClckState -> IO b) -> IO b
withClckwrks cc action = do
  let top' = fmap (\top -> top </> "_state") (clckTopDir cc)
  withAcid top' $ \acid ->
    withPlugins cc (initialClckPluginsSt acid) $ \plugins -> do
      u <- atomically $ newTVar 0
      let clckState = ClckState { acidState        = acid
--                                        , currentPage      = PageId 0
                                , uniqueId         = u
                                , adminMenus       = []
                                , enableAnalytics  = clckEnableAnalytics cc
                                , plugins          = plugins
                                , requestInit      = return ()
                                }
      action clckState

simpleClckwrks :: ClckwrksConfig -> IO ()
simpleClckwrks cc =
  withClckwrks cc $ \clckState ->
      do let baseURI =
               case calcTLSBaseURI cc of
                 (Just baseUri) -> baseUri
                 Nothing -> calcBaseURI cc
         (clckState', cc') <- (clckInitHook cc) baseURI clckState cc
         let p = plugins clckState'
         hooks <- getPostHooks p
         ~(Just clckShowFn) <- getPluginRouteFn p "clck"
         let showFn = \url params -> clckShowFn url []
         clckState'' <- execClckT showFn clckState' $ sequence_ hooks

         mHttpsTID <-
             case clckTLS cc' of
               Nothing -> return Nothing
               (Just TLSSettings{..}) ->
                   do let tlsConf = nullTLSConf { tlsPort = clckTLSPort
                                                , tlsCert = clckTLSCert
                                                , tlsKey  = clckTLSKey
                                                , tlsCA   = clckTLSCA
                                                }
                      tid <- forkIO $ simpleHTTPS tlsConf (handlers cc' clckState'')
                      return (Just tid)

         httpTID  <- if isNothing mHttpsTID
                       then forkIO $ simpleHTTP (nullConf { port = clckPort cc' }) (handlers cc' clckState'')
                       else forkIO $ simpleHTTP (nullConf { port = clckPort cc' }) forceHTTPS
         -- putStrLn "Server Now Listening For Requests."
         waitForTermination
         killThread httpTID
         maybe (return ()) killThread mHttpsTID

    where
      handlers :: ClckwrksConfig -> ClckState -> ServerPart Response
      handlers cc clckState =
       do forceCanonicalHost
          decodeBody (defaultBodyPolicy "/tmp/" (10 * 10^6)  (1 * 10^6)  (1 * 10^6))
          requestInit clckState
          msum $
            [ jsHandlers cc
            , dir "favicon.ico" $ notFound (toResponse ())
            , dir "static"      $ (liftIO $ Clckwrks.getDataFileName "static") >>= serveDirectory DisableBrowsing []
            , do nullDir
                 mRR <- query' (acidCore . acidState $ clckState) GetRootRedirect
                 seeOther (fromMaybe ("/page/view-page/1") mRR) (toResponse ()) -- FIXME: get redirect location from database
            , clckSite cc clckState
            ]

      forceCanonicalHost :: ServerPart ()
      forceCanonicalHost =
          do rq <- askRq
             case getHeader "host" rq of
               Nothing -> return ()
               (Just hostBS) ->
                   if (clckHostname cc == (B.unpack $ B.takeWhile (/= ':') hostBS))
                   then return ()
                   else escape $ seeOther ((if rqSecure rq then (fromJust $ calcTLSBaseURI cc) else (calcBaseURI cc)) <> (Text.pack $ rqUri rq) <> (Text.pack $ rqQuery rq)) (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 =
          msum [ do method GET
                    rq <- askRq
                    seeOther ((fromJust $ calcTLSBaseURI cc) <> (Text.pack $ rqUri rq) <> (Text.pack $ rqQuery rq)) (toResponse ())
               , do forbidden (toResponse ("https:// required." :: Text))
               ]

jsHandlers :: (Happstack m) => ClckwrksConfig -> m Response
jsHandlers c =
  msum [ dir "jquery"      $ serveDirectory DisableBrowsing [] (clckJQueryPath c)
       , dir "jquery-ui"   $ serveDirectory DisableBrowsing [] (clckJQueryUIPath c)
       , dir "jstree"      $ serveDirectory DisableBrowsing [] (clckJSTreePath c)
       , dir "json2"       $ serveDirectory DisableBrowsing [] (clckJSON2Path c)
       ]

clckSite :: ClckwrksConfig -> ClckState -> ServerPart Response
clckSite cc clckState =
    do ~(Just clckShowFn) <- getPluginRouteFn (plugins clckState) (Text.pack "clck")
       evalClckT clckShowFn clckState (pluginsHandler (plugins clckState))

pluginsHandler :: (Functor m, ServerMonad m, FilterMonad Response m, MonadIO m) =>
               Plugins theme (m Response) hook config ppm
            -> m Response
pluginsHandler plugins =
    do paths <- (map Text.pack . rqPaths) <$> askRq
       case paths of
         (p : ps) ->
             do e <- liftIO $ serve plugins p ps
                case e of
                  (Right c) -> c
                  (Left e) -> notFound $ toResponse e
         _ -> notFound (toResponse ())