Lib.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}

-- needed for creating [Char] instances
{-# LANGUAGE FlexibleInstances #-}

-- Use the following to allow records to have name field names.
-- {-# LANGUAGE DuplicateRecordFields #-}

module Lib
where

import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai as Wai
import Network.HTTP.Types.Status (status200, status404)
import qualified Control.Concurrent.STM as Stm
import qualified Data.Text as T
import qualified Data.ByteString.Lazy as BL
import qualified Data.Binary as Bin
import qualified Data.Aeson as Aeson
import GHC.Generics (Generic)

import qualified Data.ByteString as B
import Data.ByteString.Lazy.UTF8 as BLU

-------------------------------------------------------------------------------
-- STM State type
-------------------------------------------------------------------------------
type State a = Stm.TVar a

-------------------------------------------------------------------------------
-- StatefulHandler type
-------------------------------------------------------------------------------
type StatefulHandler a = StatefulRequest a -> StatefulResponse a

-------------------------------------------------------------------------------
-- StatefulApplication type
-------------------------------------------------------------------------------
type StatefulApplication a = State a -> StatefulHandler a -> Wai.Application

-------------------------------------------------------------------------------
-- StatefulRequest Record
-------------------------------------------------------------------------------
data StatefulRequest a
  = StatefulRequest
     { state  :: a
     , method :: B.ByteString
     , path   :: [T.Text]
     , body   :: BL.ByteString
     }

-------------------------------------------------------------------------------
-- StatefulResponse Record
-------------------------------------------------------------------------------
data StatefulResponse a
 = StatefulResponse
    { newState :: Maybe a
    , output   :: Wai.Response
    }

-------------------------------------------------------------------------------
-- Stateful Application
-------------------------------------------------------------------------------
statefulApp :: StatefulApplication Int
statefulApp state handler request respond
  = do
     body <- Wai.strictRequestBody request
     v    <- Stm.atomically $ Stm.readTVar state
     let method                           = Wai.requestMethod request
         path                             = Wai.pathInfo request
         req                              = StatefulRequest v method path body
         (StatefulResponse maybeV output) = handler req
     case maybeV of
       Just newV -> Stm.atomically $ Stm.writeTVar state (newV)
       Nothing   -> return () -- Only write to STM if state is updated.
     respond output

-------------------------------------------------------------------------------
-- ResponseOutput Utilities
-------------------------------------------------------------------------------
class ResponseOutput a where
 plainTxt :: a -> Wai.Response
 error404 :: a -> Wai.Response

instance ResponseOutput [Char] where -- Requires FlexibleInstances directive.
 plainTxt str = plainTxt' . BLU.fromString $ str
 error404 str = error404' . BLU.fromString $ str

instance ResponseOutput BL.ByteString where
 plainTxt str = plainTxt' str
 error404 str = error404' str

instance ResponseOutput B.ByteString where
 plainTxt str = plainTxt' . Bin.encode $ str
 error404 str = error404' . Bin.encode $ str

instance ResponseOutput T.Text where
 plainTxt str = plainTxt' . Bin.encode $ str
 error404 str = error404' . Bin.encode $ str

instance ResponseOutput Int where
 plainTxt int = plainTxt' . Bin.encode . show $ int
 error404 int = error404' . Bin.encode . show $ int

plainTxt' :: BL.ByteString -> Wai.Response
plainTxt' str
  = Wai.responseLBS status200 [("Content-Type", "text/plain")] str

error404' :: BL.ByteString -> Wai.Response
error404' str
  = Wai.responseLBS status404 [("Content-Type", "text/plain")] str

-- ****************************************************************************
-- EXAMPLE APP
-- ****************************************************************************

-------------------------------------------------------------------------------
-- Example Stateful Router for App
-------------------------------------------------------------------------------
router :: StatefulHandler Int
router req
 = case ((method req), (path req)) of
     ("GET",  [])              -> StatefulResponse Nothing (plainTxt ("Hello World!" :: String))
     ("GET",  ["hello", name]) -> StatefulResponse Nothing (plainTxt $ "Hello " <> name <> "!")
     ("POST", ["echo"])        -> StatefulResponse Nothing (plainTxt . body $ req)
     ("POST", ["inc"])         -> inc req
     ("POST", ["person"])      -> person req
     _                         -> StatefulResponse Nothing (error404 ("404 - WTF" :: String))

-------------------------------------------------------------------------------
-- State processing Handler
-------------------------------------------------------------------------------
inc :: StatefulHandler Int
inc (StatefulRequest state _ _ _)
  = StatefulResponse (Just newState) (plainTxt newState)
    where newState = state + 1

-------------------------------------------------------------------------------
-- JSON processing Handler
-------------------------------------------------------------------------------
data Person
  = Person
      { name :: String
      , age  :: Int
      }
      deriving (Generic, Show)

instance Aeson.FromJSON Person
instance Aeson.ToJSON Person
  where toEncoding = Aeson.genericToEncoding Aeson.defaultOptions

person :: StatefulHandler a
person (StatefulRequest _ _ _ body) = StatefulResponse Nothing (plainTxt output)
  where
    output
      = case (Aeson.decode  body) :: Maybe Person of
          Just p  -> Aeson.encode p -- echo the Person back as a JSON string.
          Nothing -> "Failed to decode body as a Person: " <> body


-------------------------------------------------------------------------------
-- main function
-------------------------------------------------------------------------------
run :: IO ()
run
  = do
      state <- Stm.atomically (Stm.newTVar 0)
      putStrLn "Running on http://localhost:8080 ..."
      Warp.run 8080 (statefulApp state router)