diff --git a/servant-0.4-hspec-wai-json.hsfiles b/servant-0.4-hspec-wai-json.hsfiles new file mode 100644 index 0000000..1222d14 --- /dev/null +++ b/servant-0.4-hspec-wai-json.hsfiles @@ -0,0 +1,242 @@ +{-# START_FILE package.yaml #-} +name: {{name}} +version: "0.1" +category: Web +maintainer: {{author-email}}{{^author-email}}example@example.com{{/author-email}} + +ghc-options: -Wall + +tests: + spec: + main: Spec.hs + source-dirs: + - test + - src + dependencies: + - bytestring + - hspec + - hspec-wai + - hspec-wai-json + - http-types + - lens + - string-conversions + - wai-extra + +executables: + {{name}}-server: + main: {{name}}-server.hs + source-dirs: + - src + - exe + +dependencies: + - base == 4.* + - aeson + - containers + - either + - servant-server == 0.4.* + - transformers + - wai + - warp +{-# START_FILE .ghci #-} +:set -itest -isrc +{-# START_FILE Setup.hs #-} +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain +{-# START_FILE test/Spec.hs #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# START_FILE test/AppSpec.hs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module AppSpec where + +import Data.Aeson (ToJSON, encode, eitherDecode') +import Data.ByteString +import Data.String.Conversions +import Network.HTTP.Types +import Network.Wai.Test (SResponse(..)) +import Test.Hspec +import Test.Hspec.Wai +import Test.Hspec.Wai.JSON + +import App + +spec :: Spec +spec = do + with app $ do + describe "GET /item" $ do + it "returns an empty list" $ do + get "/item" `shouldRespondWith` + [json|{payload: []}|] + + describe "POST /item" $ do + it "allows to post an item" $ do + let item :: JsonObject String + item = JsonObject "foo" + postJson "/item" item `shouldRespondWith` + [json|{payload: 0}|]{ + matchStatus = 201 + } + + it "allows to post and retrieve an item" $ do + let item :: JsonObject String + item = JsonObject "foo" + response <- postJson "/item" item + let Right (JsonObject (iid :: Integer)) = + eitherDecode' (simpleBody response) + get ("/item/" <> cs (show iid)) `shouldRespondWith` + [json|{itemId: 0, itemText: "foo"}|] + + it "allows to post and retrieve items as a list" $ do + let a :: JsonObject String + a = JsonObject "foo" + b :: JsonObject String + b = JsonObject "bar" + _ <- postJson "/item" a + _ <- postJson "/item" b + get ("/item") `shouldRespondWith` + [json| + {payload: + [ {itemId: 0, itemText: "foo"} + , {itemId: 1, itemText: "bar"} + ] + } + |] + +postJson :: ToJSON body => ByteString -> body -> WaiSession SResponse +postJson path body = + request methodPost path [("content-type", "application/json")] + (encode body) +{-# START_FILE src/App.hs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} + +module App where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Either +import Data.Aeson +import GHC.Generics +import Network.Wai +import Network.Wai.Handler.Warp +import Prelude hiding (lookup) +import Servant +import System.IO + +import DB +import Item + +run :: Int -> IO () +run port = do + let settings = + setPort port $ + setBeforeMainLoop (hPutStrLn stderr ("listening on port " ++ show port)) + defaultSettings + runSettings settings =<< app + +app :: IO Application +app = do + db <- mkDB + return $ serve simpleApi $ simpleServer db + +type SimpleApi = + "item" :> Get '[JSON] (JsonObject [Item]) :<|> + "item" :> ReqBody '[JSON] (JsonObject String) + :> Post '[JSON] (JsonObject Integer) :<|> + "item" :> Capture "id" Integer :> Get '[JSON] Item + +simpleApi :: Proxy SimpleApi +simpleApi = Proxy + +simpleServer :: DB -> Server SimpleApi +simpleServer db = + App.listItems db :<|> + postItem db :<|> + getItem db + +type Handler = EitherT ServantErr IO + +listItems :: DB -> Handler (JsonObject [Item]) +listItems db = liftIO $ JsonObject <$> DB.listItems db + +postItem :: DB -> JsonObject String -> Handler (JsonObject Integer) +postItem db (JsonObject item) = liftIO $ JsonObject <$> insertItem db item + +getItem :: DB -> Integer -> Handler Item +getItem db iid = do + mItem <- liftIO $ lookupItem db iid + case mItem of + Nothing -> left err404 + Just item -> return item + +-- * json helpers + +data JsonObject a + = JsonObject { + payload :: a + } + deriving (Generic, Show, Eq, Ord) + +instance ToJSON a => ToJSON (JsonObject a) +instance FromJSON a => FromJSON (JsonObject a) +{-# START_FILE src/Item.hs #-} +{-# LANGUAGE DeriveGeneric #-} + +module Item where + +import Data.Aeson +import GHC.Generics + +data Item + = Item { + itemId :: Integer, + itemText :: String + } + deriving (Generic, Show, Eq, Ord) + +instance ToJSON Item +{-# START_FILE src/DB.hs #-} + +module DB where + +import Control.Concurrent +import Data.Map hiding (map) +import Prelude hiding (lookup) + +import Item + +data ItemStore + = ItemStore { + nextId :: Integer, + store :: Map Integer String + } + +data DB = DB (MVar ItemStore) + +mkDB :: IO DB +mkDB = DB <$> newMVar (ItemStore 0 mempty) + +listItems :: DB -> IO [Item] +listItems (DB mvar) = withMVar mvar $ \ (ItemStore _ m) -> + return $ map (uncurry Item) $ Data.Map.toList m + +insertItem :: DB -> String -> IO Integer +insertItem (DB mvar) item = modifyMVar mvar $ \ (ItemStore next m) -> + return (ItemStore (succ next) (insert next item m), next) + +lookupItem :: DB -> Integer -> IO (Maybe Item) +lookupItem (DB mvar) iid = withMVar mvar $ \ (ItemStore _ m) -> + return $ fmap (Item iid) $ lookup iid m +{-# START_FILE exe/{{name}}-server.hs #-} + +module Main where + +import App + +main :: IO () +main = run 8000