module Yu.Core.Model.Internal
(
Nav(..)
, navToDoc
, docToNav
,
ResT(..)
, resToDoc
, docToRes
,
fromBinary
,
Mongodic(..)
, ConnectionPool
, fetchContext
, fetchRes
, fetchResAll
, updateContext
, updateItem
, updateRes
, deleteContext
, deleteItem
, deleteRes
, deleteContextMaybe
, (=@)
, module Database.MongoDB
, module Data.Pool
) where
import Control.Monad.IO.Class
import Control.Monad.Trans.Control
import Data.Pool
import Database.MongoDB
import Yu.Import
import Yu.Import.Aeson
import qualified Yu.Import.ByteString as B
import qualified Yu.Import.Text as T
import Yu.Utils.Handler
type ConnectionPool = Pool Pipe
data Nav = Nav { navUrl :: T.Text
, navLabel :: T.Text
, navOrder :: Int
}
deriving (Show)
instance Eq Nav where
n1 == n2 = navOrder n1 == navOrder n2
instance Ord Nav where
compare n1 n2 = compare (navOrder n1) (navOrder n2)
navToDoc :: Nav -> Document
navToDoc Nav{..} =
[ "index" =: navLabel
, "url" =: navUrl
, "order" =: navOrder
]
docToNav :: Document -> Maybe Nav
docToNav doc = Nav
<$> doc !? "url"
<*> doc !? "index"
<*> doc !? "order"
instance ToJSON Nav where
toJSON Nav{..} = object
[ "label" .= navLabel
, "url" .= navUrl
, "order" .= navOrder
]
data ResT = ResT
{ rIndex :: [T.Text]
, rRes :: ObjectId
, rType :: T.Text
, rCTime :: UTCTime
, rUTime :: UTCTime
, rTitle :: T.Text
, rSummary :: Maybe T.Text
, rWhose :: Maybe T.Text
, rMIME :: Maybe T.Text
, rTags :: [T.Text]
}
deriving (Show)
instance Eq ResT where
res1 == res2 = and
[ abs (rCTime res1 `diffUTCTime` rCTime res2) <= 1
, abs (rUTime res1 `diffUTCTime` rUTime res2) <= 1
, rIndex res1 == rIndex res2
, rRes res1 == rRes res2
, rType res1 == rType res2
, rTitle res1 == rTitle res2
, rSummary res1 == rSummary res2
, rWhose res1 == rWhose res2
, rMIME res1 == rMIME res2
, rTags res1 == rTags res2
]
resToDoc :: ResT -> Document
resToDoc ResT{..} =
[ "index" =: rIndex
, "res" =: rRes
, "type" =: rType
, "create-time" =: rCTime
, "update-time" =: rUTime
, "title" =: rTitle
, "summary" =: rSummary
, "whose" =: rWhose
, "mime" =: rMIME
, "tags" =: rTags
]
docToRes :: Document -> Maybe ResT
docToRes doc = ResT
<$> doc !? "index"
<*> doc !? "res"
<*> doc !? "type"
<*> doc !? "create-time"
<*> doc !? "update-time"
<*> doc !? "title"
<*> Just (doc !? "summary")
<*> Just (doc !? "whose")
<*> Just (doc !? "mime")
<*> m2l (doc !? "tags")
where
m2l (Just xs) = Just xs
m2l _ = Just []
instance ToJSON ResT where
toJSON ResT{..} = object
[ "index" .= rIndex
, "type" .= rType
, "create-time" .= rCTime
, "update-time" .= rUTime
, "title" .= rTitle
, "summary" .= rSummary
, "whose" .= rWhose
, "mime" .= rMIME
, "tags" .= rTags
]
class (MonadIO m,MonadBaseControl IO m) => Mongodic a m | m -> a where
getDefaultAccessMode :: m AccessMode
getDefaultDb :: m Database
getDbUP :: m (T.Text,T.Text)
getPool :: m ConnectionPool
fetchContext :: (MonadIO m,Val a)
=> T.Text
-> ResT
-> T.Text
-> Action m (Maybe a)
fetchContext field ResT{..} = ((!? field) <%>).findOne.select ["_id" =: rRes]
fetchRes :: MonadIO m
=> [T.Text]
-> Action m (Maybe ResT)
fetchRes index = (docToRes <%>) . findOne $ select ["index" =: index] "index"
fetchResAll :: (MonadIO m, MonadBaseControl IO m)
=> Action m [ResT]
fetchResAll = do
cur <- find $ select [] "index"
rt <- rest cur
closeCursor cur
return . catMaybes $ docToRes <$> rt
updateContext :: (MonadIO m, Val a)
=> T.Text
-> Maybe ObjectId
-> T.Text
-> a
-> Action m ObjectId
updateContext c oid field v = case oid of
Just i -> upsert (select ["_id" =: i] c) [field =: v] >> return i
_ -> (\(ObjId i) -> i) <$> insert c [field =: v]
updateItem :: (MonadIO m, Val a)
=> T.Text
-> T.Text
-> a
-> ResT
-> Action m ()
updateItem t f v uR = do
let index = rIndex uR
res <- fetchRes index
rr <- if (rType <$> res) /= Just t
then deleteContextMaybe res >> return Nothing
else return $ rRes <$> res
rO <- updateContext t rr f v
updateRes (uR {rRes = rO})
updateRes :: MonadIO m
=> ResT
-> Action m ()
updateRes res@ResT{..} =
upsert (select ["index" =: rIndex] "index") $ resToDoc res
deleteContext :: MonadIO m
=> ResT
-> T.Text
-> Action m ()
deleteContext ResT{..} c =
delete $ select ["_id" =: rRes] c
deleteRes :: MonadIO m
=> ResT
-> Action m ()
deleteRes ResT{..} =
delete $ select ["index" =: rIndex] "index"
deleteContextMaybe :: MonadIO m
=> Maybe ResT
-> Action m ()
deleteContextMaybe (Just r) = deleteContext r $ rType r
deleteContextMaybe _ = return ()
deleteItem :: MonadIO m
=> [T.Text]
-> T.Text
-> Action m ()
deleteItem index c = fetchRes index >>=
(\res -> case res of
Just r -> deleteContext r c >> deleteRes r
_ -> return ())
fromBinary :: Binary -> B.ByteString
fromBinary (Binary b) = b
infix 0 =@
(=@) :: Val v
=> Label
-> Maybe v
-> Maybe Field
(=@) l = ((Just.(l =:)) =<<)