rest-example 0.1.2 → 0.1.2.1
raw patch · 6 files changed
+91/−64 lines, 6 filesdep −monad-control
Dependencies removed: monad-control
Files
- CHANGELOG.md +1/−0
- example-api/Api/Post.hs +43/−31
- example-api/Api/Post/Comment.hs +21/−15
- example-api/Api/Test.hs +4/−0
- example-api/Api/User.hs +21/−16
- rest-example.cabal +1/−2
CHANGELOG.md view
@@ -3,6 +3,7 @@ #### 0.1.2.1 * Allow time 1.5.*+* Remove unneeded dependency on monad-control. ### 0.1.2
example-api/Api/Post.hs view
@@ -72,44 +72,56 @@ 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+get = mkIdHandler xmlJsonO handler+ where+ handler :: () -> Identifier -> ErrorT Reason_ WithPost Post+ handler _ i = do+ mpost <- liftIO . atomically . postFromIdentifier i =<< (lift . lift) (asks posts)+ case mpost of+ Nothing -> throwError NotFound+ Just a -> return a -- | List Posts with the most recent posts first. 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+list = mkListing xmlJsonO handler+ where+ handler :: Range -> ErrorT Reason_ BlogApi [Post]+ handler 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- -- Make sure the credentials are valid- checkLogin usr- pstsVar <- asks posts- psts <- liftIO . atomically . readTVar $ pstsVar- post <- liftIO $ toPost (Set.size psts + 1) usr pst- -- Validate and save the post in the same transaction.- merr <- liftIO . atomically $ do- let vt = validTitle pst psts- if not vt- then return . Just $ domainReason InvalidTitle- else if not (validContent pst)- then return . Just $ domainReason InvalidContent- else modifyTVar pstsVar (Set.insert post) >> return Nothing- maybe (return post) throwError merr+create = mkInputHandler (xmlJsonE . xmlJson) handler+ where+ handler :: UserPost -> ErrorT (Reason PostError) BlogApi Post+ handler (UserPost usr pst) = do+ -- Make sure the credentials are valid+ checkLogin usr+ pstsVar <- asks posts+ psts <- liftIO . atomically . readTVar $ pstsVar+ post <- liftIO $ toPost (Set.size psts + 1) usr pst+ -- Validate and save the post in the same transaction.+ merr <- liftIO . atomically $ do+ let vt = validTitle pst psts+ if not vt+ then return . Just $ domainReason InvalidTitle+ else if not (validContent pst)+ then return . Just $ domainReason 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+remove = mkIdHandler id handler+ where+ handler :: () -> Identifier -> ErrorT Reason_ WithPost ()+ handler _ 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 -- | Convert a User and CreatePost into a Post that can be saved. toPost :: Int -> User -> CreatePost -> IO Post
example-api/Api/Post/Comment.hs view
@@ -35,24 +35,30 @@ } list :: ListHandler WithPost-list = mkListing xmlJsonO $ \r -> do- postId <- getPostId `orThrow` NotFound- comms <- liftIO . atomically . readTVar- =<< (lift . lift) (asks comments)- return . take (count r) . drop (offset r)- . sortBy (flip $ comparing Comment.createdTime)- . maybe [] Set.toList . H.lookup postId $ comms+list = mkListing xmlJsonO handler+ where+ handler :: Range -> ErrorT Reason_ WithPost [Comment]+ handler r = do+ postId <- getPostId `orThrow` NotFound+ comms <- liftIO . atomically . readTVar+ =<< (lift . lift) (asks comments)+ return . take (count r) . drop (offset r)+ . sortBy (flip $ comparing Comment.createdTime)+ . maybe [] Set.toList . H.lookup postId $ comms create :: Handler WithPost-create = mkInputHandler (xmlJson) $ \ucomm -> do- postId <- getPostId `orThrow` NotFound- comm <- liftIO $ userCommentToComment ucomm- comms <- lift . lift $ asks comments- liftIO . atomically $- modifyTVar' comms (H.insertWith (<>) postId (Set.singleton comm))- return comm+create = mkInputHandler xmlJson handler+ where+ handler :: UserComment -> ErrorT Reason_ WithPost Comment+ handler ucomm = do+ postId <- getPostId `orThrow` NotFound+ comm <- liftIO $ userCommentToComment ucomm+ comms <- lift . lift $ asks comments+ liftIO . atomically $+ modifyTVar' comms (H.insertWith (<>) postId (Set.singleton comm))+ return comm -getPostId :: ErrorT (Reason ()) WithPost (Maybe Post.Id)+getPostId :: ErrorT Reason_ WithPost (Maybe Post.Id) getPostId = do postIdent <- ask return . fmap Post.id
example-api/Api/Test.hs view
@@ -63,6 +63,7 @@ , ("justStringO" , justStringO ) , ("preferJson" , preferJson ) , ("octetStreamOut" , octetStreamOut )+ , ("onlyInput" , onlyInput ) ] } @@ -114,3 +115,6 @@ \case "error" -> throwError $ domainReason Err _ -> return ("ok", "ok")++onlyInput :: Handler WithText+onlyInput = mkInputHandler (jsonI . someI) $ \() -> throwError NotFound
example-api/Api/User.hs view
@@ -2,7 +2,7 @@ import Control.Applicative ((<$>)) import Control.Concurrent.STM (atomically, modifyTVar, readTVar)-import Control.Monad.Error (throwError)+import Control.Monad.Error (ErrorT, throwError) import Control.Monad.Reader (ReaderT, asks) import Control.Monad.Trans (liftIO) import Data.Set (Set)@@ -10,8 +10,7 @@ import qualified Data.Set as Set import qualified Data.Text as T -import Rest (Handler, ListHandler, Range (count, offset), Resource, Void, domainReason, mkInputHandler, mkListing, mkResourceReader, named, singleRead,- withListing, xmlJsonE, xmlJsonI, xmlJsonO)+import Rest import qualified Rest.Resource as R import ApiTypes (BlogApi, ServerData (..))@@ -35,25 +34,31 @@ } list :: ListHandler BlogApi-list = mkListing xmlJsonO $ \r -> do- usrs <- liftIO . atomically . readTVar =<< asks users- return . map toUserInfo . take (count r) . drop (offset r) . Set.toList $ usrs+list = mkListing xmlJsonO handler+ where+ handler :: Range -> ErrorT Reason_ BlogApi [UserInfo]+ handler r = do+ usrs <- liftIO . atomically . readTVar =<< asks users+ return . map toUserInfo . take (count r) . drop (offset r) . Set.toList $ usrs -- | Convert a User into a representation that is safe to show to the public. toUserInfo :: User -> UserInfo toUserInfo u = UserInfo { UserInfo.name = User.name u } create :: Handler BlogApi-create = mkInputHandler (xmlJsonE . xmlJsonO . xmlJsonI) $ \usr -> do- usrs <- asks users- merr <- liftIO . atomically $ do- vu <- validUserName usr <$> readTVar usrs- if not (validPassword usr)- then return . Just $ domainReason InvalidPassword- else if not vu- then return . Just $ domainReason InvalidUserName- else modifyTVar usrs (Set.insert usr) >> return Nothing- maybe (return $ toUserInfo usr) throwError merr+create = mkInputHandler (xmlJsonE . xmlJsonO . xmlJsonI) handler+ where+ handler :: User -> ErrorT (Reason UserSignupError) BlogApi UserInfo+ handler usr = do+ usrs <- asks users+ merr <- liftIO . atomically $ do+ vu <- validUserName usr <$> readTVar usrs+ if not (validPassword usr)+ then return . Just $ domainReason InvalidPassword+ else if not vu+ then return . Just $ domainReason InvalidUserName+ else modifyTVar usrs (Set.insert usr) >> return Nothing+ maybe (return $ toUserInfo usr) throwError merr validPassword :: User.User -> Bool validPassword = (> 1) . T.length . User.password
rest-example.cabal view
@@ -1,5 +1,5 @@ name: rest-example-version: 0.1.2+version: 0.1.2.1 synopsis: Example project for rest homepage: http://www.github.com/silkapp/rest license: BSD3@@ -46,7 +46,6 @@ , generic-aeson == 0.2.* , hxt == 9.3.* , json-schema >= 0.6 && < 0.8- , monad-control == 0.3.* , mtl >= 2.0 && < 2.3 , regular == 0.3.* , regular-xmlpickler == 0.2.*