{-#LANGUAGE NoImplicitPrelude #-}
{-#LANGUAGE OverloadedStrings #-}
{-#LANGUAGE TypeFamilies #-}
{-#LANGUAGE MultiParamTypeClasses #-}
{-#LANGUAGE FlexibleInstances #-}
{-#LANGUAGE FlexibleContexts #-}
{-#LANGUAGE LambdaCase #-}
module Web.Sprinkles.Backends
(
BackendSpec (..)
, makeBackendSpecPathsAbsolute
, parseBackendURI
, BackendData (..)
, BackendMeta (..)
, Items (..)
, loadBackendData
, RawBackendCache
, rawToLBS
, rawFromLBS
)
where
import Web.Sprinkles.Prelude
import System.Random.Shuffle (shuffleM)
import Web.Sprinkles.Cache
import qualified Data.Serialize as Cereal
import Control.MaybeEitherMonad (eitherFailS)
import Web.Sprinkles.Logger (LogLevel (..))
import Network.Mime (MimeType)
import Web.Sprinkles.Backends.Spec
( BackendSpec (..)
, makeBackendSpecPathsAbsolute
, BackendType (..)
, AscDesc (..)
, FetchMode (..)
, FetchOrder (..)
, FetchOrderField (..)
, parseBackendURI
, CachePolicy (..)
, cachePolicy
)
import Web.Sprinkles.Backends.Parsers
( parseBackendData
)
import Web.Sprinkles.Backends.Data
( BackendData (..)
, BackendMeta (..)
, BackendSource (..)
, Items (..)
, reduceItems
, serializeBackendSource
, deserializeBackendSource
, rawFromLBS
, rawToLBS
)
import Web.Sprinkles.Backends.Loader
import Web.Sprinkles.Backends.Loader.Type (RequestContext (..))
import Data.Expandable
type RawBackendCache = Cache ByteString ByteString
type BackendCache = Cache BackendSpec [BackendSource]
loadBackendData :: Monad m
=> (LogLevel -> Text -> IO ())
-> RequestContext
-> RawBackendCache
-> BackendSpec
-> IO (Items (BackendData p m h))
loadBackendData writeLog context cache bspec =
fmap (reduceItems (bsFetchMode bspec)) $
fetchBackendData writeLog context cache' bspec >>=
mapM parseBackendData >>=
sorter
where
cache' = if bsCacheEnabled bspec then cache else mempty
sorter :: [BackendData p m h] -> IO [BackendData p m h]
sorter = fmap reverter . baseSorter
reverter :: [a] -> [a]
reverter = case fetchAscDesc (bsOrder bspec) of
Ascending -> id
Descending -> reverse
baseSorter :: [BackendData p m h] -> IO [BackendData p m h]
baseSorter = case fetchField (bsOrder bspec) of
ArbitraryOrder -> return
RandomOrder -> shuffleM
OrderByName -> return . sortOn (bmName . bdMeta)
OrderByMTime -> return . sortOn (bmMTime . bdMeta)
wrapBackendCache :: RawBackendCache -> BackendCache
wrapBackendCache =
transformCache
Cereal.encode
(eitherFailS . Cereal.decode)
(fmap (Just . Cereal.encode) . mapM serializeBackendSource)
(fmap Just . fmap (map deserializeBackendSource) . eitherFailS . Cereal.decode)
fetchBackendData :: (LogLevel -> Text -> IO ()) -> RequestContext -> RawBackendCache -> BackendSpec -> IO [BackendSource]
fetchBackendData writeLog loadPost rawCache spec =
cacheWrap (fetchBackendData' writeLog loadPost) spec
where
cacheWrap = case cachePolicy spec of
CacheForever -> cached cache
NoCaching -> id
cache :: BackendCache
cache = wrapBackendCache rawCache
fetchBackendData' :: (LogLevel -> Text -> IO ()) -> RequestContext -> BackendSpec -> IO [BackendSource]
fetchBackendData'
writeLog
loadPost
(BackendSpec backendType fetchMode fetchOrder mimeOverride _) =
map (overrideMime mimeOverride) <$> loader backendType writeLog loadPost fetchMode fetchOrder
overrideMime :: Maybe MimeType -> BackendSource -> BackendSource
overrideMime Nothing s = s
overrideMime (Just m) s =
s { bsMeta = (bsMeta s) { bmMimeType = m } }