{-# LANGUAGE TemplateHaskell #-}
module Snap.Snaplet.Heist.Internal where

import           Prelude
import           Control.Lens
import           Control.Monad (liftM)
import           Control.Monad.State
import qualified Data.ByteString as B
import           Data.Char
import qualified Data.HashMap.Strict as Map
import           Data.IORef
import           Data.List
import           Data.Monoid
import           Data.Text (Text)
import qualified Data.Text as T
import           Heist
import           Heist.Splices.Cache
import           System.FilePath.Posix

import           Snap.Core
import           Snap.Snaplet


data DefaultMode = Compiled | Interpreted


------------------------------------------------------------------------------
-- | The state for the Heist snaplet.  To use the Heist snaplet in your app
-- include this in your application state and use 'heistInit' to initialize
-- it.  The type parameter b will typically be the base state type for your
-- application.
data Heist b = Configuring
                 { forall b. Heist b -> IORef (HeistConfig (Handler b b), DefaultMode)
_heistConfig :: IORef (HeistConfig (Handler b b), DefaultMode)
                 }
             | Running
                 { forall b. Heist b -> HeistConfig (Handler b b)
_masterConfig :: HeistConfig (Handler b b)
                 , forall b. Heist b -> HeistState (Handler b b)
_heistState   :: HeistState (Handler b b)
                 , forall b. Heist b -> CacheTagState
_heistCTS     :: CacheTagState
                 , forall b. Heist b -> DefaultMode
_defMode      :: DefaultMode
                 }

makeLenses ''Heist


------------------------------------------------------------------------------
-- | Generic initializer function that allows compiled/interpreted template
-- serving to be specified by the caller.
gHeistInit :: Handler b (Heist b) ()
           -> FilePath
           -> SnapletInit b (Heist b)
gHeistInit :: forall b.
Handler b (Heist b) () -> FilePath -> SnapletInit b (Heist b)
gHeistInit Handler b (Heist b) ()
serve FilePath
templateDir = do
    forall b v.
Text
-> Text
-> Maybe (IO FilePath)
-> Initializer b v v
-> SnapletInit b v
makeSnaplet Text
"heist" Text
"" forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ do
        Heist b
hs <- forall b.
FilePath
-> HeistConfig (Handler b b) -> Initializer b (Heist b) (Heist b)
heistInitWorker FilePath
templateDir forall {m :: * -> *}. HeistConfig m
defaultConfig
        forall b v. [(ByteString, Handler b v ())] -> Initializer b v ()
addRoutes [ (ByteString
"", Handler b (Heist b) ()
serve)
                  , (ByteString
"heistReload", forall (m :: * -> *) b. MonadSnap m => m b -> m b
failIfNotLocal forall b. Handler b (Heist b) ()
heistReloader)
                  ]
        forall (m :: * -> *) a. Monad m => a -> m a
return Heist b
hs
  where
    sc :: SpliceConfig m
sc = forall s t a b. ASetter s t a b -> b -> s -> t
set forall (f :: * -> *) (m :: * -> *).
Functor f =>
(Splices (Splice IO) -> f (Splices (Splice IO)))
-> SpliceConfig m -> f (SpliceConfig m)
scLoadTimeSplices forall (m :: * -> *). MonadIO m => Splices (Splice m)
defaultLoadTimeSplices forall a. Monoid a => a
mempty
    defaultConfig :: HeistConfig m
defaultConfig = forall {m :: * -> *}. HeistConfig m
emptyHeistConfig forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) (m :: * -> *).
Functor f =>
(SpliceConfig m -> f (SpliceConfig m))
-> HeistConfig m -> f (HeistConfig m)
hcSpliceConfig forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall {m :: * -> *}. SpliceConfig m
sc
                                     forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) (m :: * -> *).
Functor f =>
(Text -> f Text) -> HeistConfig m -> f (HeistConfig m)
hcNamespace forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
""
                                     forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) (m :: * -> *).
Functor f =>
(Bool -> f Bool) -> HeistConfig m -> f (HeistConfig m)
hcErrorNotBound forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True


------------------------------------------------------------------------------
-- | Internal worker function used by variants of heistInit.  This is
-- necessary because of the divide between SnapletInit and Initializer.
heistInitWorker :: FilePath
                -> HeistConfig (Handler b b)
                -> Initializer b (Heist b) (Heist b)
heistInitWorker :: forall b.
FilePath
-> HeistConfig (Handler b b) -> Initializer b (Heist b) (Heist b)
heistInitWorker FilePath
templateDir HeistConfig (Handler b b)
initialConfig = do
    FilePath
snapletPath <- forall (m :: * -> * -> * -> *) b v.
(Monad (m b v), MonadSnaplet m) =>
m b v FilePath
getSnapletFilePath
    let tDir :: FilePath
tDir = FilePath
snapletPath FilePath -> FilePath -> FilePath
</> FilePath
templateDir
    TemplateRepo
templates <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ (FilePath -> TemplateLocation
loadTemplates FilePath
tDir) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                          forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => FilePath -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall (m :: * -> *) a. Monad m => a -> m a
return
    forall b v. Text -> Initializer b v ()
printInfo forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords
        [ FilePath
"...loaded"
        , (forall a. Show a => a -> FilePath
show forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> Int
Map.size TemplateRepo
templates)
        , FilePath
"templates from"
        , FilePath
tDir
        ]
    let config :: HeistConfig (Handler b b)
config = HeistConfig (Handler b b)
initialConfig forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) (m :: * -> *).
Functor f =>
([TemplateLocation] -> f [TemplateLocation])
-> HeistConfig m -> f (HeistConfig m)
hcTemplateLocations forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~
                                 (forall a. Semigroup a => a -> a -> a
<> [FilePath -> TemplateLocation
loadTemplates FilePath
tDir])
                               forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) (m :: * -> *).
Functor f =>
((TPath -> Bool) -> f (TPath -> Bool))
-> HeistConfig m -> f (HeistConfig m)
hcCompiledTemplateFilter forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~
                                 (\TPath -> Bool
f TPath
x -> TPath -> Bool
f TPath
x Bool -> Bool -> Bool
&& TPath -> Bool
nsFilter TPath
x)

    IORef (HeistConfig (Handler b b), DefaultMode)
ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef (HeistConfig (Handler b b)
config, DefaultMode
Compiled)

    -- FIXME This runs after all the initializers, but before post init
    -- hooks registered by other snaplets.
    forall v b. (v -> IO (Either Text v)) -> Initializer b v ()
addPostInitHook forall b. Heist b -> IO (Either Text (Heist b))
finalLoadHook
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b. IORef (HeistConfig (Handler b b), DefaultMode) -> Heist b
Configuring IORef (HeistConfig (Handler b b), DefaultMode)
ref
  where
    nsFilter :: TPath -> Bool
nsFilter = forall a. Eq a => a -> a -> Bool
(/=) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'_') forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => ByteString -> Word8
B.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head


------------------------------------------------------------------------------
-- | Hook that converts the Heist type from Configuring to Running at the end
-- of initialization.
finalLoadHook :: Heist b -> IO (Either Text (Heist b))
finalLoadHook :: forall b. Heist b -> IO (Either Text (Heist b))
finalLoadHook (Configuring IORef (HeistConfig (Handler b b), DefaultMode)
ref) = do
    (HeistConfig (Handler b b)
hc,DefaultMode
dm) <- forall a. IORef a -> IO a
readIORef IORef (HeistConfig (Handler b b), DefaultMode)
ref
    Either Text (HeistState (Handler b b), CacheTagState)
res <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall {d}. Either [FilePath] d -> Either Text d
toTextErrors forall a b. (a -> b) -> a -> b
$ forall (n :: * -> *).
MonadIO n =>
HeistConfig n
-> IO (Either [FilePath] (HeistState n, CacheTagState))
initHeistWithCacheTag HeistConfig (Handler b b)
hc
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either Text (HeistState (Handler b b), CacheTagState)
res of
      Left Text
e -> forall a b. a -> Either a b
Left Text
e
      Right (HeistState (Handler b b)
hs,CacheTagState
cts) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall b.
HeistConfig (Handler b b)
-> HeistState (Handler b b)
-> CacheTagState
-> DefaultMode
-> Heist b
Running HeistConfig (Handler b b)
hc HeistState (Handler b b)
hs CacheTagState
cts DefaultMode
dm
  where
    toTextErrors :: Either [FilePath] d -> Either Text d
toTextErrors = forall a c b d. (a -> c) -> (b -> d) -> Either a b -> Either c d
mapBoth (FilePath -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\n") forall a. a -> a
id
finalLoadHook (Running HeistConfig (Handler b b)
_ HeistState (Handler b b)
_ CacheTagState
_ DefaultMode
_) =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
"finalLoadHook called while running"


mapBoth :: (a -> c) -> (b -> d) -> Either a b -> Either c d
mapBoth :: forall a c b d. (a -> c) -> (b -> d) -> Either a b -> Either c d
mapBoth a -> c
f b -> d
_ (Left a
x)  = forall a b. a -> Either a b
Left (a -> c
f a
x)
mapBoth a -> c
_ b -> d
f (Right b
x) = forall a b. b -> Either a b
Right (b -> d
f b
x)


------------------------------------------------------------------------------
-- | Handler that triggers a template reload.  For large sites, this can be
-- desireable because it may be much quicker than the full site reload
-- provided at the /admin/reload route.  This allows you to reload only the
-- heist templates  This handler is automatically set up by heistInit, but if
-- you use heistInit', then you can create your own route with it.
heistReloader :: Handler b (Heist b) ()
heistReloader :: forall b. Handler b (Heist b) ()
heistReloader = do
    Heist b
h <- forall s (m :: * -> *). MonadState s m => m s
get
    Either [FilePath] (HeistState (Handler b b))
ehs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (n :: * -> *).
Monad n =>
HeistConfig n -> IO (Either [FilePath] (HeistState n))
initHeist forall a b. (a -> b) -> a -> b
$ forall b. Heist b -> HeistConfig (Handler b b)
_masterConfig Heist b
h
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *). MonadSnap m => Text -> m ()
writeText forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unlines)
           (\HeistState (Handler b b)
hs -> do forall (m :: * -> *). MonadSnap m => Text -> m ()
writeText Text
"Heist reloaded."
                      forall v b. v -> Handler b v ()
modifyMaster forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set forall b. Traversal' (Heist b) (HeistState (Handler b b))
heistState HeistState (Handler b b)
hs Heist b
h)
           Either [FilePath] (HeistState (Handler b b))
ehs