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

import           Prelude
import           Control.Lens
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
    Text
-> Text
-> Maybe (IO FilePath)
-> Initializer b (Heist b) (Heist b)
-> SnapletInit b (Heist b)
forall b v.
Text
-> Text
-> Maybe (IO FilePath)
-> Initializer b v v
-> SnapletInit b v
makeSnaplet Text
"heist" Text
"" Maybe (IO FilePath)
forall a. Maybe a
Nothing (Initializer b (Heist b) (Heist b) -> SnapletInit b (Heist b))
-> Initializer b (Heist b) (Heist b) -> SnapletInit b (Heist b)
forall a b. (a -> b) -> a -> b
$ do
        Heist b
hs <- FilePath
-> HeistConfig (Handler b b) -> Initializer b (Heist b) (Heist b)
forall b.
FilePath
-> HeistConfig (Handler b b) -> Initializer b (Heist b) (Heist b)
heistInitWorker FilePath
templateDir HeistConfig (Handler b b)
forall {m :: * -> *}. HeistConfig m
defaultConfig
        [(ByteString, Handler b (Heist b) ())]
-> Initializer b (Heist b) ()
forall b v. [(ByteString, Handler b v ())] -> Initializer b v ()
addRoutes [ (ByteString
"", Handler b (Heist b) ()
serve)
                  , (ByteString
"heistReload", Handler b (Heist b) () -> Handler b (Heist b) ()
forall (m :: * -> *) b. MonadSnap m => m b -> m b
failIfNotLocal Handler b (Heist b) ()
forall b. Handler b (Heist b) ()
heistReloader)
                  ]
        Heist b -> Initializer b (Heist b) (Heist b)
forall (m :: * -> *) a. Monad m => a -> m a
return Heist b
hs
  where
    sc :: SpliceConfig m
sc = ASetter
  (SpliceConfig m)
  (SpliceConfig m)
  (Splices (Splice IO))
  (Splices (Splice IO))
-> Splices (Splice IO) -> SpliceConfig m -> SpliceConfig m
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (SpliceConfig m)
  (SpliceConfig m)
  (Splices (Splice IO))
  (Splices (Splice IO))
forall (f :: * -> *) (m :: * -> *).
Functor f =>
(Splices (Splice IO) -> f (Splices (Splice IO)))
-> SpliceConfig m -> f (SpliceConfig m)
scLoadTimeSplices Splices (Splice IO)
forall (m :: * -> *). MonadIO m => Splices (Splice m)
defaultLoadTimeSplices SpliceConfig m
forall a. Monoid a => a
mempty
    defaultConfig :: HeistConfig m
defaultConfig = HeistConfig m
forall {m :: * -> *}. HeistConfig m
emptyHeistConfig HeistConfig m -> (HeistConfig m -> HeistConfig m) -> HeistConfig m
forall a b. a -> (a -> b) -> b
& (SpliceConfig m -> Identity (SpliceConfig m))
-> HeistConfig m -> Identity (HeistConfig m)
forall (f :: * -> *) (m :: * -> *).
Functor f =>
(SpliceConfig m -> f (SpliceConfig m))
-> HeistConfig m -> f (HeistConfig m)
hcSpliceConfig ((SpliceConfig m -> Identity (SpliceConfig m))
 -> HeistConfig m -> Identity (HeistConfig m))
-> SpliceConfig m -> HeistConfig m -> HeistConfig m
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SpliceConfig m
forall {m :: * -> *}. SpliceConfig m
sc
                                     HeistConfig m -> (HeistConfig m -> HeistConfig m) -> HeistConfig m
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text)
-> HeistConfig m -> Identity (HeistConfig m)
forall (f :: * -> *) (m :: * -> *).
Functor f =>
(Text -> f Text) -> HeistConfig m -> f (HeistConfig m)
hcNamespace ((Text -> Identity Text)
 -> HeistConfig m -> Identity (HeistConfig m))
-> Text -> HeistConfig m -> HeistConfig m
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
""
                                     HeistConfig m -> (HeistConfig m -> HeistConfig m) -> HeistConfig m
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool)
-> HeistConfig m -> Identity (HeistConfig m)
forall (f :: * -> *) (m :: * -> *).
Functor f =>
(Bool -> f Bool) -> HeistConfig m -> f (HeistConfig m)
hcErrorNotBound ((Bool -> Identity Bool)
 -> HeistConfig m -> Identity (HeistConfig m))
-> Bool -> HeistConfig m -> HeistConfig m
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 <- Initializer b (Heist b) FilePath
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 <- IO TemplateRepo -> Initializer b (Heist b) TemplateRepo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TemplateRepo -> Initializer b (Heist b) TemplateRepo)
-> IO TemplateRepo -> Initializer b (Heist b) TemplateRepo
forall a b. (a -> b) -> a -> b
$ (FilePath -> IO (Either [FilePath] TemplateRepo)
loadTemplates FilePath
tDir) IO (Either [FilePath] TemplateRepo)
-> (Either [FilePath] TemplateRepo -> IO TemplateRepo)
-> IO TemplateRepo
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                          ([FilePath] -> IO TemplateRepo)
-> (TemplateRepo -> IO TemplateRepo)
-> Either [FilePath] TemplateRepo
-> IO TemplateRepo
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> IO TemplateRepo
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO TemplateRepo)
-> ([FilePath] -> FilePath) -> [FilePath] -> IO TemplateRepo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) TemplateRepo -> IO TemplateRepo
forall (m :: * -> *) a. Monad m => a -> m a
return
    Text -> Initializer b (Heist b) ()
forall b v. Text -> Initializer b v ()
printInfo (Text -> Initializer b (Heist b) ())
-> Text -> Initializer b (Heist b) ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords
        [ FilePath
"...loaded"
        , (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ TemplateRepo -> Int
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 HeistConfig (Handler b b)
-> (HeistConfig (Handler b b) -> HeistConfig (Handler b b))
-> HeistConfig (Handler b b)
forall a b. a -> (a -> b) -> b
& ([IO (Either [FilePath] TemplateRepo)]
 -> Identity [IO (Either [FilePath] TemplateRepo)])
-> HeistConfig (Handler b b)
-> Identity (HeistConfig (Handler b b))
forall (f :: * -> *) (m :: * -> *).
Functor f =>
([IO (Either [FilePath] TemplateRepo)]
 -> f [IO (Either [FilePath] TemplateRepo)])
-> HeistConfig m -> f (HeistConfig m)
hcTemplateLocations (([IO (Either [FilePath] TemplateRepo)]
  -> Identity [IO (Either [FilePath] TemplateRepo)])
 -> HeistConfig (Handler b b)
 -> Identity (HeistConfig (Handler b b)))
-> ([IO (Either [FilePath] TemplateRepo)]
    -> [IO (Either [FilePath] TemplateRepo)])
-> HeistConfig (Handler b b)
-> HeistConfig (Handler b b)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~
                                 ([IO (Either [FilePath] TemplateRepo)]
-> [IO (Either [FilePath] TemplateRepo)]
-> [IO (Either [FilePath] TemplateRepo)]
forall a. Semigroup a => a -> a -> a
<> [FilePath -> IO (Either [FilePath] TemplateRepo)
loadTemplates FilePath
tDir])
                               HeistConfig (Handler b b)
-> (HeistConfig (Handler b b) -> HeistConfig (Handler b b))
-> HeistConfig (Handler b b)
forall a b. a -> (a -> b) -> b
& ((TPath -> Bool) -> Identity (TPath -> Bool))
-> HeistConfig (Handler b b)
-> Identity (HeistConfig (Handler b b))
forall (f :: * -> *) (m :: * -> *).
Functor f =>
((TPath -> Bool) -> f (TPath -> Bool))
-> HeistConfig m -> f (HeistConfig m)
hcCompiledTemplateFilter (((TPath -> Bool) -> Identity (TPath -> Bool))
 -> HeistConfig (Handler b b)
 -> Identity (HeistConfig (Handler b b)))
-> ((TPath -> Bool) -> TPath -> Bool)
-> HeistConfig (Handler b b)
-> HeistConfig (Handler b b)
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 <- IO (IORef (HeistConfig (Handler b b), DefaultMode))
-> Initializer
     b (Heist b) (IORef (HeistConfig (Handler b b), DefaultMode))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (HeistConfig (Handler b b), DefaultMode))
 -> Initializer
      b (Heist b) (IORef (HeistConfig (Handler b b), DefaultMode)))
-> IO (IORef (HeistConfig (Handler b b), DefaultMode))
-> Initializer
     b (Heist b) (IORef (HeistConfig (Handler b b), DefaultMode))
forall a b. (a -> b) -> a -> b
$ (HeistConfig (Handler b b), DefaultMode)
-> IO (IORef (HeistConfig (Handler b b), DefaultMode))
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.
    (Heist b -> IO (Either Text (Heist b)))
-> Initializer b (Heist b) ()
forall v b. (v -> IO (Either Text v)) -> Initializer b v ()
addPostInitHook Heist b -> IO (Either Text (Heist b))
forall b. Heist b -> IO (Either Text (Heist b))
finalLoadHook
    Heist b -> Initializer b (Heist b) (Heist b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Heist b -> Initializer b (Heist b) (Heist b))
-> Heist b -> Initializer b (Heist b) (Heist b)
forall a b. (a -> b) -> a -> b
$ IORef (HeistConfig (Handler b b), DefaultMode) -> Heist b
forall b. IORef (HeistConfig (Handler b b), DefaultMode) -> Heist b
Configuring IORef (HeistConfig (Handler b b), DefaultMode)
ref
  where
    nsFilter :: TPath -> Bool
nsFilter = Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
(/=) (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'_') (Word8 -> Bool) -> (TPath -> Word8) -> TPath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Word8
B.head (ByteString -> Word8) -> (TPath -> ByteString) -> TPath -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TPath -> ByteString
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) <- IORef (HeistConfig (Handler b b), DefaultMode)
-> IO (HeistConfig (Handler b b), DefaultMode)
forall a. IORef a -> IO a
readIORef IORef (HeistConfig (Handler b b), DefaultMode)
ref
    Either Text (HeistState (Handler b b), CacheTagState)
res <- (Either [FilePath] (HeistState (Handler b b), CacheTagState)
 -> Either Text (HeistState (Handler b b), CacheTagState))
-> IO (Either [FilePath] (HeistState (Handler b b), CacheTagState))
-> IO (Either Text (HeistState (Handler b b), CacheTagState))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Either [FilePath] (HeistState (Handler b b), CacheTagState)
-> Either Text (HeistState (Handler b b), CacheTagState)
forall {d}. Either [FilePath] d -> Either Text d
toTextErrors (IO (Either [FilePath] (HeistState (Handler b b), CacheTagState))
 -> IO (Either Text (HeistState (Handler b b), CacheTagState)))
-> IO (Either [FilePath] (HeistState (Handler b b), CacheTagState))
-> IO (Either Text (HeistState (Handler b b), CacheTagState))
forall a b. (a -> b) -> a -> b
$ HeistConfig (Handler b b)
-> IO (Either [FilePath] (HeistState (Handler b b), CacheTagState))
forall (n :: * -> *).
MonadIO n =>
HeistConfig n
-> IO (Either [FilePath] (HeistState n, CacheTagState))
initHeistWithCacheTag HeistConfig (Handler b b)
hc
    Either Text (Heist b) -> IO (Either Text (Heist b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Heist b) -> IO (Either Text (Heist b)))
-> Either Text (Heist b) -> IO (Either Text (Heist b))
forall a b. (a -> b) -> a -> b
$ case Either Text (HeistState (Handler b b), CacheTagState)
res of
      Left Text
e -> Text -> Either Text (Heist b)
forall a b. a -> Either a b
Left Text
e
      Right (HeistState (Handler b b)
hs,CacheTagState
cts) -> Heist b -> Either Text (Heist b)
forall a b. b -> Either a b
Right (Heist b -> Either Text (Heist b))
-> Heist b -> Either Text (Heist b)
forall a b. (a -> b) -> a -> b
$ HeistConfig (Handler b b)
-> HeistState (Handler b b)
-> CacheTagState
-> DefaultMode
-> Heist 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 = ([FilePath] -> Text)
-> (d -> d) -> Either [FilePath] d -> Either Text d
forall a c b d. (a -> c) -> (b -> d) -> Either a b -> Either c d
mapBoth (FilePath -> Text
T.pack (FilePath -> Text)
-> ([FilePath] -> FilePath) -> [FilePath] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\n") d -> d
forall a. a -> a
id
finalLoadHook (Running HeistConfig (Handler b b)
_ HeistState (Handler b b)
_ CacheTagState
_ DefaultMode
_) =
    Either Text (Heist b) -> IO (Either Text (Heist b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Heist b) -> IO (Either Text (Heist b)))
-> Either Text (Heist b) -> IO (Either Text (Heist b))
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (Heist 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)  = c -> Either c d
forall a b. a -> Either a b
Left (a -> c
f a
x)
mapBoth a -> c
_ b -> d
f (Right b
x) = d -> Either c d
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 <- Handler b (Heist b) (Heist b)
forall s (m :: * -> *). MonadState s m => m s
get
    Either [FilePath] (HeistState (Handler b b))
ehs <- IO (Either [FilePath] (HeistState (Handler b b)))
-> Handler
     b (Heist b) (Either [FilePath] (HeistState (Handler b b)))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either [FilePath] (HeistState (Handler b b)))
 -> Handler
      b (Heist b) (Either [FilePath] (HeistState (Handler b b))))
-> IO (Either [FilePath] (HeistState (Handler b b)))
-> Handler
     b (Heist b) (Either [FilePath] (HeistState (Handler b b)))
forall a b. (a -> b) -> a -> b
$ HeistConfig (Handler b b)
-> IO (Either [FilePath] (HeistState (Handler b b)))
forall (n :: * -> *).
Monad n =>
HeistConfig n -> IO (Either [FilePath] (HeistState n))
initHeist (HeistConfig (Handler b b)
 -> IO (Either [FilePath] (HeistState (Handler b b))))
-> HeistConfig (Handler b b)
-> IO (Either [FilePath] (HeistState (Handler b b)))
forall a b. (a -> b) -> a -> b
$ Heist b -> HeistConfig (Handler b b)
forall b. Heist b -> HeistConfig (Handler b b)
_masterConfig Heist b
h
    ([FilePath] -> Handler b (Heist b) ())
-> (HeistState (Handler b b) -> Handler b (Heist b) ())
-> Either [FilePath] (HeistState (Handler b b))
-> Handler b (Heist b) ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Handler b (Heist b) ()
forall (m :: * -> *). MonadSnap m => Text -> m ()
writeText (Text -> Handler b (Heist b) ())
-> ([FilePath] -> Text) -> [FilePath] -> Handler b (Heist b) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Text)
-> ([FilePath] -> FilePath) -> [FilePath] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unlines)
           (\HeistState (Handler b b)
hs -> do Text -> Handler b (Heist b) ()
forall (m :: * -> *). MonadSnap m => Text -> m ()
writeText Text
"Heist reloaded."
                      Heist b -> Handler b (Heist b) ()
forall v b. v -> Handler b v ()
modifyMaster (Heist b -> Handler b (Heist b) ())
-> Heist b -> Handler b (Heist b) ()
forall a b. (a -> b) -> a -> b
$ ASetter
  (Heist b)
  (Heist b)
  (HeistState (Handler b b))
  (HeistState (Handler b b))
-> HeistState (Handler b b) -> Heist b -> Heist b
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (Heist b)
  (Heist b)
  (HeistState (Handler b b))
  (HeistState (Handler b b))
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