diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Silk B.V. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Silk B.V. nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example-api/Api.hs b/example-api/Api.hs new file mode 100644 --- /dev/null +++ b/example-api/Api.hs @@ -0,0 +1,23 @@ +-- | The API path hierarchy +module Api where + +import Rest.Api + +import ApiTypes (BlogApi) +import qualified Api.Post as Post +import qualified Api.User as User +import qualified Api.Post.Comment as Post.Comment + +-- | Defines a versioned api +api :: Api BlogApi +api = [(mkVersion 1 0 0, Some1 blog)] + +-- _ The entire routing table for v1.0.0 of the blog +blog :: Router BlogApi BlogApi +blog = + root -/ user + -/ post --/ comment + where + user = route User.resource + post = route Post.resource + comment = route Post.Comment.resource diff --git a/example-api/Api/Post.hs b/example-api/Api/Post.hs new file mode 100644 --- /dev/null +++ b/example-api/Api/Post.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DeriveDataTypeable #-} +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 + +-- | Post extends the root of the API with a reader containing the ways to identify a Post in our URLs. +-- Currently only by the title of the post. +type WithPost = ReaderT Identifier BlogApi + +-- | Defines the /post api end-point. +resource :: Resource BlogApi WithPost Identifier () Void +resource = mkResourceReader + { R.name = "post" -- Name of the HTTP path segment. + , R.schema = withListing () $ named [("id", singleRead ById), ("latest", single Latest)] + , R.list = const list -- list is requested by GET /post which gives a listing of posts. + , R.create = Just create -- PUT /post to create a new Post. + , 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 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 + +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 (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 + +-- | Convert a User and CreatePost into a Post that can be saved. +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 + } + +-- | A Post's title must be unique and non-empty. +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 + +-- | A Post's content must be non-empty. +validContent :: CreatePost -> Bool +validContent = (>= 1) . T.length . CreatePost.content + +-- | Throw an error if the user isn't logged in. +checkLogin :: User -> ErrorT (Reason e) BlogApi () +checkLogin usr = do + usrs <- liftIO . atomically . readTVar =<< asks users + unless (usr `F.elem` usrs) $ throwError NotAllowed diff --git a/example-api/Api/Post/Comment.hs b/example-api/Api/Post/Comment.hs new file mode 100644 --- /dev/null +++ b/example-api/Api/Post/Comment.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Api.Post.Comment (resource) where + +import Control.Concurrent.STM (atomically, modifyTVar', readTVar) +import Control.Monad.Reader +import Control.Monad.Trans.Error +import Data.List +import Data.Monoid +import Data.Ord +import Data.Time +import qualified Data.HashMap.Strict as H +import qualified Data.Set as Set + +import Rest +import qualified Rest.Resource as R + +import Api.Post (WithPost, postFromIdentifier) +import ApiTypes +import Type.Comment (Comment (Comment)) +import Type.UserComment (UserComment (UserComment)) +import qualified Type.Comment as Comment +import qualified Type.Post as Post +import qualified Type.User as User + +type Identifier = String + +type WithComment = ReaderT Identifier WithPost + +resource :: Resource WithPost WithComment Identifier () Void +resource = mkResourceReader + { R.name = "comment" + , R.schema = withListing () $ named [("id", singleRead id)] + , R.list = const list + , R.create = Just create -- PUT /post to create a new Post. + } + +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 + +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 + +getPostId :: ErrorT (Reason ()) WithPost (Maybe Post.Id) +getPostId = do + postIdent <- ask + return . fmap Post.id + =<< liftIO . atomically . postFromIdentifier postIdent + =<< (lift . lift) (asks posts) + +userCommentToComment :: UserComment -> IO Comment +userCommentToComment (UserComment u content) = do + t <- getCurrentTime + return $ Comment (User.name u) t content diff --git a/example-api/Api/User.hs b/example-api/Api/User.hs new file mode 100644 --- /dev/null +++ b/example-api/Api/User.hs @@ -0,0 +1,66 @@ +module Api.User (resource) where + +import Control.Applicative ((<$>)) +import Control.Concurrent.STM (atomically, modifyTVar, readTVar) +import Control.Monad.Error (throwError) +import Control.Monad.Reader (ReaderT, asks) +import Control.Monad.Trans (liftIO) +import Data.Set (Set) +import qualified Data.Foldable as F +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 qualified Rest.Resource as R + +import ApiTypes (BlogApi, ServerData (..)) +import Type.User (User) +import Type.UserInfo (UserInfo (..)) +import Type.UserSignupError (UserSignupError (..)) +import qualified Type.User as User +import qualified Type.UserInfo as UserInfo + +-- | User extends the root of the API with a reader containing the ways to identify a user in our URLs. +-- Currently only by the user name. +type WithUser = ReaderT User.Name BlogApi + +-- | Defines the /user api end-point. +resource :: Resource BlogApi WithUser User.Name () Void +resource = mkResourceReader + { R.name = "user" -- Name of the HTTP path segment. + , R.schema = withListing () $ named [("name", singleRead id)] + , R.list = const list -- requested by GET /user, gives a paginated listing of users. + , R.create = Just create -- PUT /user creates a new user + } + +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 + +-- | 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 (const 400) InvalidPassword + else if not vu + then return . Just $ domainReason (const 400) 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 + +validUserName :: User -> Set User -> Bool +validUserName u usrs = + let un = User.name u + available = F.all ((un /=). User.name) usrs + nonEmpty = (> 1) . T.length $ un + in available && nonEmpty diff --git a/example-api/ApiTypes.hs b/example-api/ApiTypes.hs new file mode 100644 --- /dev/null +++ b/example-api/ApiTypes.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module ApiTypes where + +import Control.Applicative (Applicative) +import Control.Concurrent.STM (TVar) +import Control.Monad.Reader (MonadReader, ReaderT (..)) +import Control.Monad.Trans (MonadIO) +import Data.HashMap.Strict (HashMap) +import Data.Set (Set) + +import Type.Comment (Comment) +import Type.Post (Post) +import Type.User (User) +import qualified Type.Post as Post + +data ServerData = ServerData + { users :: TVar (Set User) + , posts :: TVar (Set Post) + , comments :: TVar (HashMap Post.Id (Set Comment)) + } + +newtype BlogApi a = BlogApi { unBlogApi :: ReaderT ServerData IO a } + deriving ( Applicative + , Functor + , Monad + , MonadIO + , MonadReader ServerData + ) + +runBlogApi :: ServerData -> BlogApi a -> IO a +runBlogApi serverdata = flip runReaderT serverdata . unBlogApi diff --git a/example-api/Example.hs b/example-api/Example.hs new file mode 100644 --- /dev/null +++ b/example-api/Example.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +module Example (exampleBlog) where + +import Control.Applicative +import Control.Concurrent.STM (newTVarIO) +import Data.HashMap.Strict (HashMap) +import Data.Set (Set) +import qualified Data.HashMap.Strict as H +import qualified Data.Set as Set + +import ApiTypes (ServerData (..)) +import Type.Comment (Comment (Comment)) +import Type.Post (Post (Post)) +import Type.User (User (User)) + +-- Set up the server state +exampleBlog :: IO ServerData +exampleBlog = ServerData + <$> newTVarIO mockUsers + <*> newTVarIO mockPosts + <*> newTVarIO mockComments + +-- | Prepoulated users +mockUsers :: Set User +mockUsers = Set.fromList + [ User "adam" "1234" + , User "erik" "2345" + , User "sebas" "3456" + ] + +-- | Prepopulated posts +mockPosts :: Set Post +mockPosts = Set.fromList + [ Post 0 "adam" (read "2014-03-31 15:34:00") "First post" "Hello world!" + , Post 1 "erik" (read "2014-04-01 13:37:00") "Rest is awesome" "Just wanted to tell the world!" + ] + +mockComments :: HashMap Int (Set Comment) +mockComments = H.fromList + [(0, Set.fromList [Comment "adam" (read "2014-06-08 14:00:00") "This is the best post I've ever written, please be gentle"])] diff --git a/example-api/Type/Comment.hs b/example-api/Type/Comment.hs new file mode 100644 --- /dev/null +++ b/example-api/Type/Comment.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE + DeriveDataTypeable + , DeriveGeneric + , TemplateHaskell + , TypeFamilies + #-} +module Type.Comment (Comment (..)) where + +import Data.Aeson +import Data.JSON.Schema +import Data.Text (Text) +import Data.Time +import Data.Typeable +import GHC.Generics +import Generics.Regular +import Generics.Regular.XmlPickler +import Text.XML.HXT.Arrow.Pickle + +import Type.Post () +import qualified Type.User as User + +data Comment = Comment + { author :: User.Name + , createdTime :: UTCTime + , content :: Text + } deriving (Eq, Generic, Ord, Show, Typeable) + +deriveAll ''Comment "PFComment" +type instance PF Comment = PFComment + +instance XmlPickler Comment where xpickle = gxpickle +instance JSONSchema Comment where schema = gSchema +instance FromJSON Comment +instance ToJSON Comment diff --git a/example-api/Type/CreatePost.hs b/example-api/Type/CreatePost.hs new file mode 100644 --- /dev/null +++ b/example-api/Type/CreatePost.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE + DeriveDataTypeable + , DeriveGeneric + , TemplateHaskell + , TypeFamilies + #-} +module Type.CreatePost where + +import Data.Aeson +import Data.JSON.Schema +import Data.Text (Text) +import Data.Typeable +import GHC.Generics +import Generics.Regular +import Generics.Regular.XmlPickler +import Text.XML.HXT.Arrow.Pickle + +type Title = Text + +data CreatePost = CreatePost + { title :: Title + , content :: Text + } deriving (Eq, Generic, Ord, Show, Typeable) + +deriveAll ''CreatePost "PFCreatePost" +type instance PF CreatePost = PFCreatePost + +instance XmlPickler CreatePost where xpickle = gxpickle +instance JSONSchema CreatePost where schema = gSchema +instance FromJSON CreatePost +instance ToJSON CreatePost diff --git a/example-api/Type/Post.hs b/example-api/Type/Post.hs new file mode 100644 --- /dev/null +++ b/example-api/Type/Post.hs @@ -0,0 +1,41 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE + DeriveDataTypeable + , DeriveGeneric + , TemplateHaskell + , TypeFamilies + #-} +module Type.Post where + +import Data.Aeson +import Data.JSON.Schema +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.Typeable +import GHC.Generics +import Generics.Regular +import Generics.Regular.XmlPickler +import Text.XML.HXT.Arrow.Pickle + +import qualified Type.User as User + +type Id = Int +type Title = Text + +data Post = Post + { id :: Id + , author :: User.Name + , createdTime :: UTCTime + , title :: Title + , content :: Text + } deriving (Eq, Generic, Ord, Show, Typeable) + +deriveAll ''Post "PFPost" +type instance PF Post = PFPost + +instance XmlPickler Post where xpickle = gxpickle +instance JSONSchema Post where schema = gSchema +instance ToJSON Post +instance FromJSON Post + +instance XmlPickler UTCTime where xpickle = xpPrim diff --git a/example-api/Type/PostError.hs b/example-api/Type/PostError.hs new file mode 100644 --- /dev/null +++ b/example-api/Type/PostError.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE + DeriveDataTypeable + , DeriveGeneric + , TemplateHaskell + , TypeFamilies + #-} +module Type.PostError where + +import Data.Aeson +import Data.JSON.Schema +import Data.Typeable +import GHC.Generics +import Generics.Regular +import Generics.Regular.XmlPickler +import Text.XML.HXT.Arrow.Pickle + +data PostError = InvalidTitle | InvalidContent + deriving (Eq, Generic, Ord, Show, Typeable) + +deriveAll ''PostError "PFPostError" +type instance PF PostError = PFPostError + +instance XmlPickler PostError where xpickle = gxpickle +instance JSONSchema PostError where schema = gSchema +instance FromJSON PostError +instance ToJSON PostError diff --git a/example-api/Type/User.hs b/example-api/Type/User.hs new file mode 100644 --- /dev/null +++ b/example-api/Type/User.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE + DeriveDataTypeable + , DeriveGeneric + , TemplateHaskell + , TypeFamilies + #-} +module Type.User where + +import Data.Aeson +import Data.JSON.Schema +import Data.Text (Text) +import Data.Typeable +import GHC.Generics +import Generics.Regular +import Generics.Regular.XmlPickler +import Text.XML.HXT.Arrow.Pickle + +type Name = Text +type Password = Text + +data User = User + { name :: Name + , password :: Password + } deriving (Eq, Generic, Ord, Show, Typeable) + +deriveAll ''User "PFUser" +type instance PF User = PFUser + +instance XmlPickler User where xpickle = gxpickle +instance JSONSchema User where schema = gSchema +instance FromJSON User +instance ToJSON User +-- We might want to skip the ToJSON instance so we don't accidentally +-- serve passwords, but this type is accepted on signup which means a +-- haskell client needs to be able to serialize it. diff --git a/example-api/Type/UserComment.hs b/example-api/Type/UserComment.hs new file mode 100644 --- /dev/null +++ b/example-api/Type/UserComment.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE + DeriveDataTypeable + , DeriveGeneric + , TemplateHaskell + , TypeFamilies + #-} +module Type.UserComment where + +import Data.Aeson +import Data.JSON.Schema +import Data.Text (Text) +import Data.Typeable +import GHC.Generics +import Generics.Regular +import Generics.Regular.XmlPickler +import Text.XML.HXT.Arrow.Pickle + +import Type.User (User) + +data UserComment = UserComment + { user :: User + , comment :: Text + } deriving (Eq, Generic, Ord, Show, Typeable) + +deriveAll ''UserComment "PFUserComment" +type instance PF UserComment = PFUserComment + +instance XmlPickler UserComment where xpickle = gxpickle +instance JSONSchema UserComment where schema = gSchema +instance FromJSON UserComment +instance ToJSON UserComment diff --git a/example-api/Type/UserInfo.hs b/example-api/Type/UserInfo.hs new file mode 100644 --- /dev/null +++ b/example-api/Type/UserInfo.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE + DeriveDataTypeable + , DeriveGeneric + , TemplateHaskell + , TypeFamilies + #-} +module Type.UserInfo where + +import Data.Aeson +import Data.JSON.Schema +import Data.Typeable +import GHC.Generics +import Generics.Regular +import Generics.Regular.XmlPickler +import Text.XML.HXT.Arrow.Pickle + +import qualified Type.User as User + +data UserInfo = UserInfo + { name :: User.Name + } deriving (Generic, Show, Typeable) + +deriveAll ''UserInfo "PFUserInfo" +type instance PF UserInfo = PFUserInfo + +instance XmlPickler UserInfo where xpickle = gxpickle +instance JSONSchema UserInfo where schema = gSchema +instance ToJSON UserInfo +instance FromJSON UserInfo diff --git a/example-api/Type/UserPost.hs b/example-api/Type/UserPost.hs new file mode 100644 --- /dev/null +++ b/example-api/Type/UserPost.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE + DeriveDataTypeable + , DeriveGeneric + , TemplateHaskell + , TypeFamilies + #-} +module Type.UserPost where + +import Data.Aeson +import Data.JSON.Schema +import Data.Typeable +import GHC.Generics +import Generics.Regular +import Generics.Regular.XmlPickler +import Text.XML.HXT.Arrow.Pickle + +import Type.CreatePost (CreatePost) +import Type.User (User) + +data UserPost = UserPost { user :: User, post :: CreatePost } + deriving (Eq, Generic, Ord, Show, Typeable) + +deriveAll ''UserPost "PFUserPost" +type instance PF UserPost = PFUserPost + +instance XmlPickler UserPost where xpickle = gxpickle +instance JSONSchema UserPost where schema = gSchema +instance FromJSON UserPost +instance ToJSON UserPost diff --git a/example-api/Type/UserSignupError.hs b/example-api/Type/UserSignupError.hs new file mode 100644 --- /dev/null +++ b/example-api/Type/UserSignupError.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE + DeriveDataTypeable + , DeriveGeneric + , TemplateHaskell + , TypeFamilies + #-} +module Type.UserSignupError where + +import Data.Aeson +import Data.JSON.Schema +import Data.Typeable +import GHC.Generics +import Generics.Regular +import Generics.Regular.XmlPickler +import Text.XML.HXT.Arrow.Pickle + +data UserSignupError = InvalidPassword | InvalidUserName + deriving (Eq, Generic, Ord, Show, Typeable) + +deriveAll ''UserSignupError "PFUserSignupError" +type instance PF UserSignupError = PFUserSignupError + +instance XmlPickler UserSignupError where xpickle = gxpickle +instance JSONSchema UserSignupError where schema = gSchema +instance FromJSON UserSignupError +instance ToJSON UserSignupError diff --git a/generate/Main.hs b/generate/Main.hs new file mode 100644 --- /dev/null +++ b/generate/Main.hs @@ -0,0 +1,21 @@ +module Main (main) where + +import Rest.Gen.Types +import qualified Rest.Gen as Gen +import qualified Rest.Gen.Config as Gen + +import qualified Api + +main :: IO () +main = do + config <- Gen.configFromArgs "rest-example-gen" + Gen.generate + config + "RestExample" + Api.api + [] -- Additional modules to put in the generated cabal file + [] -- Additional imports in every module, typically used for orphan instances + -- rest-gen finds the originating module for each data type, when + -- these are re-exported from an internal module they can be + -- rewritten to something more stable. + [(ModuleName "Data.Text.Internal", ModuleName "Data.Text")] diff --git a/happstack/Main.hs b/happstack/Main.hs new file mode 100644 --- /dev/null +++ b/happstack/Main.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Control.Concurrent (forkIO, killThread) +import Control.Monad.Trans (liftIO) +import Happstack.Server.SimpleHTTP + +import Rest.Driver.Happstack (apiToHandler') + +import Api (api) +import ApiTypes (ServerData (..), runBlogApi) +import Example (exampleBlog) + +-- | Run the server +main :: IO () +main = do + -- Set up the server state + serverData <- exampleBlog + + -- Start happstack + putStrLn "Starting happstack server on http://localhost:3000" + tid <- forkIO $ simpleHTTP (Conf 3000 Nothing Nothing 60 Nothing) (handle serverData) + + -- Exit gracefully + waitForTermination + killThread tid + +-- | Request handler +handle :: ServerData -> ServerPartT IO Response +handle serverData = apiToHandler' (liftIO . runBlogApi serverData) api + diff --git a/rest-example.cabal b/rest-example.cabal new file mode 100644 --- /dev/null +++ b/rest-example.cabal @@ -0,0 +1,148 @@ +name: rest-example +version: 0.1.0.1 +synopsis: Example project for rest +homepage: http://www.github.com/silkapp/rest +license: BSD3 +license-file: LICENSE +author: Silk B.V. +maintainer: code@silk.co +copyright: 2014 Silk B.V. +category: Web +build-type: Simple +cabal-version: >=1.10 + +extra-source-files: LICENSE + +library + default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: example-api + exposed-modules: + Api + Api.Post + Api.Post.Comment + Api.User + ApiTypes + Example + Type.Comment + Type.CreatePost + Type.Post + Type.PostError + Type.User + Type.UserComment + Type.UserInfo + Type.UserPost + Type.UserSignupError + build-depends: + base >= 4.6 && < 4.8 + , aeson >= 0.7 && < 0.9 + , containers >= 0.3 && < 0.6 + , filepath >= 1.1 && < 1.4 + , hxt == 9.3.* + , json-schema == 0.6.* + , monad-control == 0.3.* + , mtl >= 2.0 && < 2.3 + , regular == 0.3.* + , regular-xmlpickler == 0.2.* + , rest-core >= 0.31 && < 0.33 + , rest-types == 1.10.* + , safe >= 0.2 && < 0.4 + , transformers >= 0.2 && < 0.4 + , stm >= 2.1 && < 2.5 + , text >= 0.10 && < 1.2 + , time >= 1.1 && < 1.5 + , transformers-base == 0.4.* + , unordered-containers == 0.2.* + +------------------------------------------------------------------------------- +-- Executables linking against the rest-example library. + +flag happstack + description: Build the rest on happstack example. + default: False + manual: True + +flag wai + description: Build the rest on wai example. + default: False + manual: True + +flag snap + description: Build the rest on snap example. + default: False + manual: True + +flag gen + description: Build the rest on happstack example. + default: True + manual: True + +executable rest-example-happstack + default-language: Haskell2010 + ghc-options: -Wall + main-is: Main.hs + hs-source-dirs: happstack + if flag(happstack) + buildable: True + build-depends: + base >= 4.6 && < 4.8 + , happstack-server >= 7.1 && < 7.4 + , mtl >= 2.0 && < 2.3 + , rest-core >= 0.31 && < 0.33 + , rest-example + , rest-happstack == 0.2.* + else + buildable: False + +executable rest-example-wai + default-language: Haskell2010 + ghc-options: -Wall + main-is: Main.hs + hs-source-dirs: wai + if flag(wai) + buildable: True + build-depends: + base >= 4.6 && < 4.8 + , mtl >= 2.0 && < 2.3 + , rest-core >= 0.31 && < 0.33 + , rest-example + , rest-wai == 0.1.* + , wai >= 2.1 && < 3.1 + , warp >= 2.1 && < 3.1 + else + buildable: False + +executable rest-example-snap + default-language: Haskell2010 + ghc-options: -Wall + main-is: Main.hs + hs-source-dirs: snap + if flag(snap) + buildable: True + build-depends: + base >= 4.6 && < 4.8 + , mtl >= 2.0 && < 2.3 + , rest-core >= 0.31 && < 0.33 + , rest-example + , rest-snap == 0.1.* + , snap-core == 0.9.* + , snap-server == 0.9.* + else + buildable: False + +executable rest-example-gen + default-language: Haskell2010 + ghc-options: -Wall + main-is: Main.hs + hs-source-dirs: generate + if flag(gen) + buildable: True + build-depends: + base >= 4.6 && < 4.8 + , mtl >= 2.0 && < 2.3 + , rest-core >= 0.31 && < 0.33 + , rest-example + , rest-gen == 0.14.* + else + buildable: False + diff --git a/snap/Main.hs b/snap/Main.hs new file mode 100644 --- /dev/null +++ b/snap/Main.hs @@ -0,0 +1,31 @@ +module Main (main) where + +import Control.Monad.Trans (liftIO) +import Snap.Http.Server +import Snap.Core + +import Rest.Driver.Snap (apiToHandler') + +import Api (api) +import ApiTypes (ServerData (..), runBlogApi) +import Example (exampleBlog) + +-- | Run the server +main :: IO () +main = do + -- Set up the server state + serverData <- exampleBlog + + -- Setup the Snap configuration. + let cfg = setPort 3000 + . setAccessLog ConfigNoLog + . setErrorLog ConfigNoLog + $ defaultConfig + + -- Start snap + httpServe cfg (handle serverData) + +-- | Request handler +handle :: ServerData -> Snap () +handle serverData = apiToHandler' (liftIO . runBlogApi serverData) api + diff --git a/wai/Main.hs b/wai/Main.hs new file mode 100644 --- /dev/null +++ b/wai/Main.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Network.Wai.Handler.Warp +import Rest.Driver.Wai (apiToApplication) + +import Api (api) +import ApiTypes (runBlogApi) +import Example (exampleBlog) + +main :: IO () +main = do + + -- Set up the server state for the blog and start warp. + putStrLn "Starting warp server on http://localhost:3000" + serverData <- exampleBlog + run 3000 $ + apiToApplication (runBlogApi serverData) api +