content: {-# 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 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{..}) ->
                     case (clckTLSCert, clckTLSKey) of
                     (Just certPath, Just keyPath) -> do
                       let tlsConf = nullTLSConf { tlsPort = clckTLSPort
                                                 , tlsCert = certPath
                                                 , tlsKey  = keyPath
                                                 , tlsCA   = clckTLSCA
                                                 }
                       tid <- forkIO $ simpleHTTPS tlsConf (handlers cc' clckState'')
                       return (Just tid)
                     _ -> return Nothing
  
  
           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
            req <- askRq
            when (canHaveBody (rqMethod req)) $
              do (p, mDisk, mRam, mHeader) <- query' (acidCore $ acidState clckState) GetBodyPolicy
                 decodeBody (defaultBodyPolicy p mDisk mRam mHeader)
            requestInit clckState
            msum $
              [ jsHandlers cc
              , 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 isSecure cc 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 cc (plugins clckState))
  
  pluginsHandler :: (Functor m, Happstack m, MonadIO m) =>
                    ClckwrksConfig
                 -> Plugins theme (m Response) hook config ppm
              -> m Response
  pluginsHandler cc plugins@(Plugins tvp) =
      do ps' <- liftIO $ atomically $ readTVar tvp
         req <- askRq
         let paths' = map Text.pack $ rqPaths req
             params'=
               let conv :: (String, Input) -> (Text, Maybe Text)
                   conv (k, i) =
                     case inputValue i of
                       (Left _)   -> (Text.pack k, Nothing)
                       (Right bs) -> (Text.pack k, Just $ decodeUtf8With lenientDecode (LB.toStrict bs))
               in map conv (rqInputsQuery req)
         -- we figure out which plugin to call by looking at the
         -- first path segment in the url
         let cont paths =
               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 ())
  
         -- 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 pluginsRewrite ps' of
           Nothing  -> cont paths'
           (Just (mf, _)) ->
             let conv :: (Text, Maybe Text) -> (String, Input)
                 conv (k, v) = (Text.unpack k, maybe (simpleInput "") (\v' -> simpleInput $ Text.unpack v') v)
             in do f <- liftIO mf
                   case f paths' params' of
                     (Just (Rewrite, paths, params))  ->
                       let qry = decodeUtf8With lenientDecode $ LB.toStrict $ toLazyByteString $ renderQueryText True params
                           pi  = (decodeUtf8With lenientDecode $ LB.toStrict $ toLazyByteString $ encodePathSegments paths)
                       in
                         localRq (\req -> req { rqQuery       = UTF8.toString $ toLazyByteString $ renderQueryText True params
                                              , rqPaths       = map Text.unpack paths
                                              , rqUri         = Text.unpack $ (if isSecure cc req then (fromJust $ calcTLSBaseURI cc) else (calcBaseURI cc)) <> pi <> qry
                                              , rqInputsQuery = map conv params
                                              }) $ do -- rq <- askRq
                                                      -- liftIO $ print rq
                                                      cont paths
                     (Just (Redirect mBaseURI, paths, params))  ->
                       let qry = decodeUtf8With lenientDecode $ LB.toStrict $ toLazyByteString $ renderQueryText True params
                           pi  = (decodeUtf8With lenientDecode $ LB.toStrict $ toLazyByteString $ encodePathSegments paths)
                       in
                         do -- liftIO $ putStrLn $ show $ rqQuery req
                            escape $ seeOther ((fromMaybe (if isSecure cc req then (fromJust $ calcTLSBaseURI cc) else (calcBaseURI cc)) mBaseURI) <> pi <> qry) (toResponse ())
                     Nothing -> cont paths'
  
  --                (Redirect, paths) -> seeOther
  