{-# 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
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
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
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)
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
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)
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