servant-0.4.hsfiles

{-# 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
{-# START_FILE {{name}}.cabal #-}
-- This file has been generated from package.yaml by hpack version 0.10.0.
--
-- see: https://github.com/sol/hpack

name:           tmp
version:        0.1
category:       Web
maintainer:     example@example.com
build-type:     Simple
cabal-version:  >= 1.10

executable tmp-server
  main-is: tmp-server.hs
  hs-source-dirs:
      src
    , exe
  ghc-options: -Wall
  build-depends:
      base == 4.*
    , aeson
    , containers
    , either
    , servant-server == 0.4.*
    , transformers
    , wai
    , warp
  other-modules:
      App
      DB
      Item
  default-language: Haskell2010

test-suite spec
  type: exitcode-stdio-1.0
  main-is: Spec.hs
  hs-source-dirs:
      test
    , src
  ghc-options: -Wall
  build-depends:
      base == 4.*
    , aeson
    , containers
    , either
    , servant-server == 0.4.*
    , transformers
    , wai
    , warp
    , bytestring
    , hspec
    , hspec-wai
    , hspec-wai-json
    , http-types
    , lens
    , string-conversions
    , wai-extra
  other-modules:
      AppSpec
      App
      DB
      Item
  default-language: Haskell2010