module Yu.Core.Model
(
runDb
, runDbDefault
,
fetchFrame
, updateFrame
, fetchPost
, updatePost
, fetchResourceB
, updateResourceB
, fetchResourceT
, updateResourceT
, fetchStatic
, updateStatic
, fetchQuery
, updateQuery
, fetchMaybeI
, fetchMaybeR
,
fetchNav
, updateNav
, deleteNav
,
module Yu.Core.Model.Internal
) where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Control
import Data.Pool
import Text.Blaze.Html (Html (..))
import qualified Text.Blaze.Html as TBH
import Yu.Core.Model.Internal
import Yu.Core.Model.TH
import Yu.Import
import Yu.Import.ByteString (ByteString (..))
import Yu.Import.Text (Text (..))
import Yu.Utils.Handler
import Yu.Utils.Handler
preEscapedToHtml :: Text -> Html
preEscapedToHtml = TBH.preEscapedToHtml
makeFetch 'preEscapedToHtml "frame" ''Html "html" "frame"
makeUpdate "frame" ''Text "html" "frame"
makeFetch 'preEscapedToHtml "post" ''Html "html" "post"
makeUpdate "post" ''Text "html" "post"
makeFetch 'id "resourceT" ''Text "text" "resource"
makeUpdate "resourceT" ''Text "text" "resource"
makeFetch 'fromBinary "resourceB" ''ByteString "binary" "resource"
makeUpdate "resourceB" ''Binary "binary" "resource"
makeFetch 'id "static" ''Text "url" "static"
makeUpdate "static" ''Text "url" "static"
makeFetch 'id "query" ''Text "var" "query"
makeUpdate "query" ''Text "var" "query"
fetchMaybeI :: MonadIO m
=> (ResT -> Action m (Maybe a))
-> [Text]
-> Action m (Maybe a)
fetchMaybeI mf idx =
fetchRes idx >>= fetchMaybeR mf
fetchMaybeR :: MonadIO m
=> (ResT -> Action m (Maybe a))
-> Maybe ResT
-> Action m (Maybe a)
fetchMaybeR mf (Just r) = mf r
fetchMaybeR _ _ = return Nothing
fetchNav :: (MonadBaseControl IO m, MonadIO m)
=> Action m [Nav]
fetchNav = do
cr <- find $ select [] "nav"
navs <- map docToNav <$> rest cr
closeCursor cr
return $ catMaybes navs
updateNav :: MonadIO m
=> Maybe Text
-> Maybe Text
-> Maybe Int
-> Action m ()
updateNav label url order =
void $ upsert (select ["label" =: label] "nav") $ catMaybes
[ Just ("index" =: label)
, "url" =@ url
, "order" =@ order
]
deleteNav :: MonadIO m
=> Maybe Text
-> Action m ()
deleteNav label =
delete $ select (catMaybes ["index" =@ label]) "nav"
runDb :: Mongodic site m
=> AccessMode
-> Database
-> Action m a
-> m a
runDb am db mf = getPool >>= \pool ->
withResource pool $ \p -> do
(user,pass) <- getDbUP
access p am db $ do
auth user pass
mf
runDbDefault :: Mongodic site m
=> Action m a
-> m a
runDbDefault mf = do
am <- getDefaultAccessMode
db <- getDefaultDb
runDb am db mf