module Api.Post
( Identifier (..)
, WithPost
, resource
, postFromIdentifier
) where
import Control.Applicative
import Control.Concurrent.STM (STM, TVar, atomically, modifyTVar, readTVar)
import Control.Monad (unless)
import Control.Monad.Error (ErrorT, throwError)
import Control.Monad.Reader (ReaderT, asks)
import Control.Monad.Trans (lift, liftIO)
import Data.List (sortBy)
import Data.Ord (comparing)
import Data.Set (Set)
import Data.Time
import Data.Typeable
import Safe
import qualified Data.Foldable as F
import qualified Data.Set as Set
import qualified Data.Text as T
import Rest
import Rest.Info
import Rest.Types.ShowUrl
import qualified Rest.Resource as R
import ApiTypes
import Type.CreatePost (CreatePost)
import Type.Post (Post (Post))
import Type.PostError (PostError (..))
import Type.User (User)
import Type.UserPost (UserPost (UserPost))
import qualified Type.CreatePost as CreatePost
import qualified Type.Post as Post
import qualified Type.User as User
data Identifier
= Latest
| ById Int
deriving (Eq, Show, Read, Typeable)
instance Info Identifier where
describe _ = "identifier"
instance ShowUrl Identifier where
showUrl Latest = "latest"
showUrl (ById i) = show i
type WithPost = ReaderT Identifier BlogApi
resource :: Resource BlogApi WithPost Identifier () Void
resource = mkResourceReader
{ R.name = "post"
, R.schema = withListing () $ named [("id", singleRead ById), ("latest", single Latest)]
, R.list = const list
, R.create = Just create
, R.get = Just get
, R.remove = Just remove
}
postFromIdentifier :: Identifier -> TVar (Set Post) -> STM (Maybe Post)
postFromIdentifier i pv = finder <$> readTVar pv
where
finder = case i of
ById ident -> F.find ((== ident) . Post.id) . Set.toList
Latest -> headMay . sortBy (flip $ comparing Post.createdTime) . Set.toList
get :: Handler WithPost
get = mkIdHandler xmlJsonO $ \_ i -> do
mpost <- liftIO . atomically . postFromIdentifier i =<< (lift . lift) (asks posts)
case mpost of
Nothing -> throwError NotFound
Just a -> return a
list :: ListHandler BlogApi
list = mkListing xmlJsonO $ \r -> do
psts <- liftIO . atomically . readTVar =<< asks posts
return . take (count r) . drop (offset r) . sortBy (flip $ comparing Post.createdTime) . Set.toList $ psts
create :: Handler BlogApi
create = mkInputHandler (xmlJsonE . xmlJson) $ \(UserPost usr pst) -> do
checkLogin usr
pstsVar <- asks posts
psts <- liftIO . atomically . readTVar $ pstsVar
post <- liftIO $ toPost (Set.size psts + 1) usr pst
merr <- liftIO . atomically $ do
let vt = validTitle pst psts
if not vt
then return . Just $ domainReason (const 400) InvalidTitle
else if not (validContent pst)
then return . Just $ domainReason (const 400) InvalidContent
else modifyTVar pstsVar (Set.insert post) >> return Nothing
maybe (return post) throwError merr
remove :: Handler WithPost
remove = mkIdHandler id $ \_ i -> do
pstsVar <- lift . lift $ asks posts
merr <- liftIO . atomically $ do
mpost <- postFromIdentifier i pstsVar
case mpost of
Nothing -> return . Just $ NotFound
Just post -> modifyTVar pstsVar (Set.delete post) >> return Nothing
maybe (return ()) throwError merr
toPost :: Int -> User -> CreatePost -> IO Post
toPost i u p = do
t <- getCurrentTime
return Post
{ Post.id = i
, Post.author = User.name u
, Post.createdTime = t
, Post.title = CreatePost.title p
, Post.content = CreatePost.content p
}
validTitle :: CreatePost -> Set Post -> Bool
validTitle p psts =
let pt = CreatePost.title p
nonEmpty = (>= 1) . T.length $ pt
available = F.all ((pt /=) . Post.title) psts
in available && nonEmpty
validContent :: CreatePost -> Bool
validContent = (>= 1) . T.length . CreatePost.content
checkLogin :: User -> ErrorT (Reason e) BlogApi ()
checkLogin usr = do
usrs <- liftIO . atomically . readTVar =<< asks users
unless (usr `F.elem` usrs) $ throwError NotAllowed