rest-example 0.1.2.2 → 0.2.0.0
raw patch · 7 files changed
+44/−33 lines, 7 filesdep +transformers-compatdep ~rest-coredep ~rest-gendep ~transformers-base
Dependencies added: transformers-compat
Dependency ranges changed: rest-core, rest-gen, transformers-base
Files
- CHANGELOG.md +4/−0
- example-api/Api/Post.hs +7/−6
- example-api/Api/Post/Comment.hs +4/−4
- example-api/Api/Test.hs +10/−10
- example-api/Api/Test/DashedName.hs +2/−2
- example-api/Api/User.hs +4/−3
- rest-example.cabal +13/−8
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Changelog +#### 0.2.0.0++* Change to use `ExceptT` and bump rest dependencies+ #### 0.1.2.2 * Bump `rest-core`.
example-api/Api/Post.hs view
@@ -9,9 +9,10 @@ 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.Error.Class import Control.Monad.Reader (ReaderT, asks) import Control.Monad.Trans (lift, liftIO)+import Control.Monad.Trans.Except (ExceptT) import Data.List (sortBy) import Data.Ord (comparing) import Data.Set (Set)@@ -74,7 +75,7 @@ get :: Handler WithPost get = mkIdHandler xmlJsonO handler where- handler :: () -> Identifier -> ErrorT Reason_ WithPost Post+ handler :: () -> Identifier -> ExceptT Reason_ WithPost Post handler _ i = do mpost <- liftIO . atomically . postFromIdentifier i =<< (lift . lift) (asks posts) case mpost of@@ -85,7 +86,7 @@ list :: ListHandler BlogApi list = mkListing xmlJsonO handler where- handler :: Range -> ErrorT Reason_ BlogApi [Post]+ handler :: Range -> ExceptT 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@@ -93,7 +94,7 @@ create :: Handler BlogApi create = mkInputHandler (xmlJsonE . xmlJson) handler where- handler :: UserPost -> ErrorT (Reason PostError) BlogApi Post+ handler :: UserPost -> ExceptT (Reason PostError) BlogApi Post handler (UserPost usr pst) = do -- Make sure the credentials are valid checkLogin usr@@ -113,7 +114,7 @@ remove :: Handler WithPost remove = mkIdHandler id handler where- handler :: () -> Identifier -> ErrorT Reason_ WithPost ()+ handler :: () -> Identifier -> ExceptT Reason_ WithPost () handler _ i = do pstsVar <- lift . lift $ asks posts merr <- liftIO . atomically $ do@@ -148,7 +149,7 @@ validContent = (>= 1) . T.length . CreatePost.content -- | Throw an error if the user isn't logged in.-checkLogin :: User -> ErrorT (Reason e) BlogApi ()+checkLogin :: User -> ExceptT (Reason e) BlogApi () checkLogin usr = do usrs <- liftIO . atomically . readTVar =<< asks users unless (usr `F.elem` usrs) $ throwError NotAllowed
example-api/Api/Post/Comment.hs view
@@ -3,7 +3,7 @@ import Control.Concurrent.STM (atomically, modifyTVar', readTVar) import Control.Monad.Reader-import Control.Monad.Trans.Error+import Control.Monad.Trans.Except import Data.List import Data.Monoid import Data.Ord@@ -37,7 +37,7 @@ list :: ListHandler WithPost list = mkListing xmlJsonO handler where- handler :: Range -> ErrorT Reason_ WithPost [Comment]+ handler :: Range -> ExceptT Reason_ WithPost [Comment] handler r = do postId <- getPostId `orThrow` NotFound comms <- liftIO . atomically . readTVar@@ -49,7 +49,7 @@ create :: Handler WithPost create = mkInputHandler xmlJson handler where- handler :: UserComment -> ErrorT Reason_ WithPost Comment+ handler :: UserComment -> ExceptT Reason_ WithPost Comment handler ucomm = do postId <- getPostId `orThrow` NotFound comm <- liftIO $ userCommentToComment ucomm@@ -58,7 +58,7 @@ modifyTVar' comms (H.insertWith (<>) postId (Set.singleton comm)) return comm -getPostId :: ErrorT Reason_ WithPost (Maybe Post.Id)+getPostId :: ExceptT Reason_ WithPost (Maybe Post.Id) getPostId = do postIdent <- ask return . fmap Post.id
example-api/Api/Test.hs view
@@ -9,8 +9,8 @@ #-} module Api.Test where +import Control.Monad.Error.Class import Control.Monad.Reader-import Control.Monad.Trans.Error import Data.Aeson import Data.Data import Data.JSON.Schema@@ -71,41 +71,41 @@ noResponse = mkConstHandler id $ return () onlyError :: Handler WithText-onlyError = mkConstHandler (jsonE . someE) $+onlyError = mkConstHandler jsonE $ throwError $ domainReason Err differentFormats :: Handler WithText-differentFormats = mkInputHandler (jsonE . someE . xmlO . someO . stringI . someI) $+differentFormats = mkInputHandler (jsonE . xmlO . stringI) $ \case "error" -> throwError $ domainReason Err _ -> return Ok intersectedFormats :: Handler WithText-intersectedFormats = mkInputHandler (jsonE . someE . xmlO . jsonO . someO . stringI . someI) $+intersectedFormats = mkInputHandler (jsonE . xmlO . jsonO . stringI) $ \case "error" -> throwError $ domainReason Err _ -> return Ok intersectedFormats2 :: Handler WithText-intersectedFormats2 = mkInputHandler (xmlE . someE . xmlO . jsonO . someO . stringI . someI) $+intersectedFormats2 = mkInputHandler (xmlE . xmlO . jsonO . stringI) $ \case "error" -> throwError $ domainReason Err _ -> return Ok errorImport :: Handler WithText-errorImport = mkIdHandler (stringI . rawXmlO . xmlE . someE) $ \s (_::Text) ->+errorImport = mkIdHandler (stringI . rawXmlO . xmlE) $ \s (_::Text) -> case s of "error" -> throwError $ domainReason E2.Err _ -> return "<ok/>" noError :: Handler WithText-noError = mkConstHandler (jsonO . someO) $ return Ok+noError = mkConstHandler jsonO $ return Ok justStringO :: Handler WithText-justStringO = mkConstHandler (stringO . someO) $ return "Ok"+justStringO = mkConstHandler stringO $ return "Ok" preferJson :: Handler WithText-preferJson = mkInputHandler (xmlJsonO . xmlJsonE . stringI . someI) $+preferJson = mkInputHandler (xmlJsonO . xmlJsonE . stringI) $ \case "error" -> throwError $ domainReason Err _ -> return Ok@@ -117,4 +117,4 @@ _ -> return ("ok", "ok") onlyInput :: Handler WithText-onlyInput = mkInputHandler (jsonI . someI) $ \() -> throwError NotFound+onlyInput = mkInputHandler jsonI $ \() -> throwError NotFound
example-api/Api/Test/DashedName.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE ScopedTypeVariables #-} module Api.Test.DashedName (resource) where -import Control.Monad.Error import Control.Monad.Reader+import Control.Monad.Trans.Except import Rest import qualified Rest.Resource as R @@ -22,5 +22,5 @@ remove :: Handler WithSiteSubscription remove = mkConstHandler id handler where- handler :: ErrorT Reason_ WithSiteSubscription ()+ handler :: ExceptT Reason_ WithSiteSubscription () handler = return ()
example-api/Api/User.hs view
@@ -2,9 +2,10 @@ import Control.Applicative ((<$>)) import Control.Concurrent.STM (atomically, modifyTVar, readTVar)-import Control.Monad.Error (ErrorT, throwError)+import Control.Monad.Error.Class (throwError) import Control.Monad.Reader (ReaderT, asks) import Control.Monad.Trans (liftIO)+import Control.Monad.Trans.Except (ExceptT) import Data.Set (Set) import qualified Data.Foldable as F import qualified Data.Set as Set@@ -36,7 +37,7 @@ list :: ListHandler BlogApi list = mkListing xmlJsonO handler where- handler :: Range -> ErrorT Reason_ BlogApi [UserInfo]+ handler :: Range -> ExceptT Reason_ BlogApi [UserInfo] handler r = do usrs <- liftIO . atomically . readTVar =<< asks users return . map toUserInfo . take (count r) . drop (offset r) . Set.toList $ usrs@@ -48,7 +49,7 @@ create :: Handler BlogApi create = mkInputHandler (xmlJsonE . xmlJsonO . xmlJsonI) handler where- handler :: User -> ErrorT (Reason UserSignupError) BlogApi UserInfo+ handler :: User -> ExceptT (Reason UserSignupError) BlogApi UserInfo handler usr = do usrs <- asks users merr <- liftIO . atomically $ do
rest-example.cabal view
@@ -1,5 +1,5 @@ name: rest-example-version: 0.1.2.2+version: 0.2.0.0 synopsis: Example project for rest homepage: http://www.github.com/silkapp/rest license: BSD3@@ -50,13 +50,14 @@ , mtl >= 2.0 && < 2.3 , regular == 0.3.* , regular-xmlpickler == 0.2.*- , rest-core >= 0.33 && < 0.35+ , rest-core == 0.35.* , safe >= 0.2 && < 0.4 , transformers >= 0.2 && < 0.5+ , transformers-compat == 0.4.* , stm >= 2.1 && < 2.5 , text >= 0.11 && < 1.3 , time >= 1.1 && < 1.6- , transformers-base == 0.4.*+ , transformers-base >= 0.4.4 && < 0.5 , unordered-containers == 0.2.* -------------------------------------------------------------------------------@@ -93,9 +94,10 @@ base >= 4.6 && < 4.8 , happstack-server >= 7.1 && < 7.5 , mtl >= 2.0 && < 2.3- , rest-core >= 0.33 && < 0.35+ , rest-core == 0.35.* , rest-example , rest-happstack == 0.2.*+ , transformers-compat == 0.4.* else buildable: False @@ -109,11 +111,12 @@ build-depends: base >= 4.6 && < 4.8 , mtl >= 2.0 && < 2.3- , rest-core >= 0.33 && < 0.35+ , rest-core == 0.35.* , rest-example , rest-wai == 0.1.* , wai >= 2.1 && < 3.1 , warp >= 2.1 && < 3.1+ , transformers-compat == 0.4.* else buildable: False @@ -127,11 +130,12 @@ build-depends: base >= 4.6 && < 4.8 , mtl >= 2.0 && < 2.3- , rest-core >= 0.33 && < 0.35+ , rest-core == 0.35.* , rest-example , rest-snap == 0.1.* , snap-core == 0.9.* , snap-server == 0.9.*+ , transformers-compat == 0.4.* else buildable: False @@ -145,8 +149,9 @@ build-depends: base >= 4.6 && < 4.8 , mtl >= 2.0 && < 2.3- , rest-core >= 0.33 && < 0.35+ , rest-core == 0.35.* , rest-example- , rest-gen >= 0.14 && < 0.17+ , rest-gen >= 0.14 && < 0.18+ , transformers-compat == 0.4.* else buildable: False