rest.hs

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

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

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
data PurchaseState = PState (MVar Purchases)

decide :: PurchaseState -> Purchase -> IO Decision
decide ps@(PState mv) p@Purchase{..}
  | amount > upper = return Amount
  | amount < lower = insert ps p >> return OK
  | otherwise      = do m <- takeMVar mv
                        let acc = Map.findWithDefault 0 email m
                        if acc + amount > upper
                          then putMVar mv m >> return Debt
                          else pure (Map.insertWith (+) email amount m) >>=
                               \new -> putMVar mv new >> seq new return OK
  where lower = 10
        upper = 1000

newState :: IO PurchaseState
newState = do m <- newMVar Map.empty
              return (PState m)

insert :: PurchaseState -> Purchase -> IO ()
insert (PState mv) Purchase{..} = do
  purchases <- takeMVar mv
  let hist = Map.insertWith (+) email amount purchases
  putMVar mv hist
  seq hist (return ())

main :: IO ()
main = newState >>=
       \state -> serverWith config $
                  \ _ url req ->
                  if | url_path url == "decisions" ->
                         case rqMethod req of
                            POST -> sendResponse' $ decide state <$> eitherDecode (rqBody req)
                            _    -> badRequest
                      | otherwise -> return $ respond NotFound

  where config = defaultConfig { srvLog = L.stdLogger, srvPort = 8080 }
        badRequest = return (respond BadRequest) :: IO (Response BS.ByteString)

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

sendJSON :: StatusCode -> Decision -> Response BS.ByteString
sendJSON code decision = sendJSON' code $ encode decision

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


-- curl -d '{"email":"a@b.se","first_name":"a","last_name":"b","amount":100}' http://localhost:8080/decisions