rest-stm.hs

{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
module Main where

import Control.Applicative
import Control.Concurrent.STM
import Data.Aeson
import Data.Aeson.Types ()
import Network.HTTP.Server hiding (OK)
import Network.URL
import Prelude hiding (lookup)

import qualified Data.ByteString.Lazy.Char8 as C8
import qualified Data.ByteString.Lazy as BS
import qualified Data.Text as T (Text)
import qualified Data.Map as Map
import qualified Network.HTTP.Server as H
import qualified Network.HTTP.Server.Logger as L

data Purchase = Purchase { fname  :: !T.Text
                         , lname  :: !T.Text
                         , email  :: !T.Text
                         , amount :: !Int
                         } deriving (Show, Eq)

instance FromJSON Purchase where
  parseJSON (Object o) = Purchase <$>
                         o .: "first_name" <*>
                         o .: "last_name" <*>
                         o .: "email" <*>
                         o .: "amount"
  parseJSON _          = fail "failed to parse purchase"

data Decision = OK | Amount | Debt deriving (Show, Eq)

instance ToJSON Decision where
  toJSON OK     = toJSONValue True "ok"
  toJSON Amount = toJSONValue False "amount"
  toJSON Debt   = toJSONValue False "debt"

toJSONValue :: Bool -> Value -> Value
toJSONValue b str = object ["accepted" .= b, ("reason", str)]

type Purchases = Map.Map T.Text Int

decide :: TVar Purchases -> Purchase -> IO Decision
decide ps Purchase{..} = atomically decide_
  where
    decide_ :: STM Decision
    decide_ | amount > upper = return Amount
            | amount < lower = insert >> return OK
            | otherwise      = do acc <- lookup
                                  if acc + amount > upper
                                    then return Debt
                                    else insert >> return OK
    insert = readTVar ps >>= writeTVar ps . Map.insertWith (+) email amount
    lookup = return . Map.findWithDefault 0 email =<< readTVar ps
    lower  = 10
    upper  = 1000


main :: IO ()
main = newTVarIO Map.empty >>=
       \state ->serverWith config $
                \ _sock url req ->
                   if url_path url == "decisions" then
                     case rqMethod req of
                       POST -> sendResponse' $ decide state <$> eitherDecode (rqBody req)
                       _    -> return $ H.err_response BadRequest
                   else return $ sendError NotFound empty
  where config = defaultConfig { srvLog = L.stdLogger, srvPort = 8080 }

sendResponse' :: Either String (IO Decision) -> IO (Response BS.ByteString)
sendResponse' = either (const $ return $ H.err_response BadRequest) (sendJSON H.OK <$>)

sendError :: StatusCode -> String -> Response BS.ByteString
sendError code msg = sendTxt code (C8.pack msg)

sendJSON :: StatusCode -> Decision -> Response BS.ByteString
sendJSON code decision = insertHeader HdrContentType "application/json"
                         $ sendTxt code $ encode decision

sendTxt :: StatusCode -> BS.ByteString -> Response BS.ByteString
sendTxt s txt = insertHeader HdrContentLength (show (BS.length txt))
                $ insertHeader HdrContentEncoding "UTF-8"
                $ insertHeader HdrContentEncoding "text/plain"
                $ (respond s :: Response BS.ByteString) { rspBody = txt }