content: {-# 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
                   { _heistConfig :: IORef (HeistConfig (Handler b b), DefaultMode)
                   }
               | Running
                   { _masterConfig :: HeistConfig (Handler b b)
                   , _heistState   :: HeistState (Handler b b)
                   , _heistCTS     :: CacheTagState
                   , _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 serve templateDir = do
      makeSnaplet "heist" "" Nothing $ do
          hs <- heistInitWorker templateDir defaultConfig
          addRoutes [ ("", serve)
                    , ("heistReload", failIfNotLocal heistReloader)
                    ]
          return hs
    where
      sc = set scLoadTimeSplices defaultLoadTimeSplices mempty
      defaultConfig = emptyHeistConfig & hcSpliceConfig .~ sc
                                       & hcNamespace .~ ""
                                       & hcErrorNotBound .~ 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 templateDir initialConfig = do
      snapletPath <- getSnapletFilePath
      let tDir = snapletPath </> templateDir
      templates <- liftIO $ (loadTemplates tDir) >>=
                            either (error . concat) return
      printInfo $ T.pack $ unwords
          [ "...loaded"
          , (show $ Map.size templates)
          , "templates from"
          , tDir
          ]
      let config = initialConfig & hcTemplateLocations %~
                                   (<> [loadTemplates tDir])
                                 & hcCompiledTemplateFilter %~
                                   (\f x -> f x && nsFilter x)
  
      ref <- liftIO $ newIORef (config, Compiled)
  
      -- FIXME This runs after all the initializers, but before post init
      -- hooks registered by other snaplets.
      addPostInitHook finalLoadHook
      return $ Configuring ref
    where
      nsFilter = (/=) (fromIntegral $ ord '_') . B.head . 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 (Configuring ref) = do
      (hc,dm) <- readIORef ref
      res <- liftM toTextErrors $ initHeistWithCacheTag hc
      return $ case res of
        Left e -> Left e
        Right (hs,cts) -> Right $ Running hc hs cts dm
    where
      toTextErrors = mapBoth (T.pack . intercalate "\n") id
  finalLoadHook (Running _ _ _ _) =
      return $ Left "finalLoadHook called while running"
  
  
  mapBoth :: (a -> c) -> (b -> d) -> Either a b -> Either c d
  mapBoth f _ (Left x)  = Left (f x)
  mapBoth _ f (Right x) = Right (f 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 = do
      h <- get
      ehs <- liftIO $ initHeist $ _masterConfig h
      either (writeText . T.pack . unlines)
             (\hs -> do writeText "Heist reloaded."
                        modifyMaster $ set heistState hs h)
             ehs
  