added servant-0.4 template

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}}[email protected]{{/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