wrecker-0.1.3.1: examples/Server.hs

{-# LANGUAGE ScopedTypeVariables, TypeOperators, OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric, FlexibleInstances, QuasiQuotes #-}
{-# LANGUAGE CPP, FlexibleContexts, UndecidableInstances, RecordWildCards #-}
{-# LANGUAGE DeriveFunctor, LambdaCase, OverloadedStrings #-}
{-# LANGUAGE TupleSections, GeneralizedNewtypeDeriving #-}

#ifndef _SERVER_IS_MAIN_
module Server where
#endif

import Web.Scotty (ScottyM, ActionM, json)
import Control.Concurrent
import Data.Aeson.QQ
import Control.Monad.IO.Class
import Network.Wai.Handler.Warp
  ( defaultSettings
  , openFreePort
  , Port
  )
import GHC.Generics
import Data.Aeson hiding (json)
import Data.Text (Text)
import qualified Web.Scotty as Scotty
import qualified Data.Text as T
import Data.Monoid
import Wrecker
import Wrecker.Runner
import Control.Concurrent.NextRef (NextRef)
import qualified Control.Concurrent.NextRef as NextRef
import qualified Control.Immortal as Immortal
import qualified Wrecker.Statistics as Wrecker
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai as Wai
import Network.Socket (Socket)
import qualified Network.Socket as N
import Control.Exception
import Data.Maybe (listToMaybe)
import System.Environment
import Control.Applicative

data Envelope a = Envelope { value :: a }
  deriving (Show, Eq, Generic)

instance ToJSON a => ToJSON (Envelope a)

rootRef :: Int -> Text
rootRef port = T.pack $ "http://localhost:" ++ show port

jsonE :: ToJSON a => a -> ActionM ()
jsonE = json . Envelope

data Root a = Root
  { root            :: a
  , products        :: a
  , cartsIndex      :: a
  , cartsIndexItems :: a
  , usersIndex      :: a
  , login           :: a
  , checkout        :: a
  } deriving (Show, Eq, Functor)

type RootInt = Root Int

instance Applicative Root where
 pure x = Root
          { root            = x
          , products        = x
          , login           = x
          , usersIndex      = x
          , cartsIndex      = x
          , cartsIndexItems = x
          , checkout        = x
          }

 f <*> x = Root
           { root            = root            f $ root                 x
           , products        = products        f $ products             x
           , login           = login           f $ login                x
           , usersIndex      = usersIndex      f $ usersIndex           x
           , cartsIndex      = cartsIndex      f $ cartsIndex           x
           , cartsIndexItems = cartsIndexItems f $ cartsIndexItems      x
           , checkout        = checkout        f $ checkout             x

           }

app :: RootInt -> Port -> ScottyM ()
app Root {..} port = do
  let host = rootRef port
  Scotty.get "/root" $ do
    liftIO $ threadDelay root
    jsonE [aesonQQ|
           { "products" : #{host <> "/products" }
           , "carts"    : #{host <> "/carts"    }
           , "users"    : #{host <> "/users"    }
           , "login"    : #{host <> "/login"    }
           , "checkout" : #{host <> "/checkout" }
           }
          |]

  Scotty.get "/products" $ do
    liftIO $ threadDelay products
    jsonE [aesonQQ|
             [ #{host <> "/products/0"}
             ]
           |]

  Scotty.get "/product/:id" $ do
    liftIO $ threadDelay products
    jsonE [aesonQQ|
          { "summary" : "shirt" }
          |]

  Scotty.get "/carts" $ do
    -- sleepDist gen carts
    jsonE [aesonQQ|
          [ #{host <> "/carts/0"}
          ]
          |]

  Scotty.get "/carts/:id" $ do
    liftIO $ threadDelay cartsIndex
    jsonE [aesonQQ|
          { "items" : #{host <> "/carts/0/items"}
          }
          |]

  Scotty.post "/carts/:id/items" $ do
    liftIO $ threadDelay cartsIndexItems
    jsonE [aesonQQ|
          #{host <> "/carts/0/items"}
          |]

  Scotty.get "/users" $ do
    -- sleepDist gen users
    jsonE [aesonQQ|
          [ #{host <> "/users/0"}
          ]
          |]

  Scotty.get "/users/:id" $ do
    liftIO $ threadDelay usersIndex
    jsonE [aesonQQ|
          { "cart"     : #{host <> "/carts/0"}
          , "username" : "example"
          }
          |]

  Scotty.post "/login" $ do
    liftIO $ threadDelay login
    jsonE [aesonQQ|
          #{host <> "/users/0"}
          |]

  Scotty.post "/checkout" $ do
    liftIO $ threadDelay checkout
    jsonE ()

run :: RootInt -> IO (Port, Immortal.Thread, ThreadId, NextRef AllStats)
run = start Nothing

stop :: (Port, ThreadId, NextRef AllStats) -> IO AllStats
stop (_, threadId, ref) = do
  killThread threadId
  NextRef.readLast ref

toKey :: Wai.Request -> String
toKey x = case Wai.pathInfo x of
  ["root"]                  -> "/root"
  ["products"]              -> "/products"
  "carts" : _ : "items" : _ -> "/carts/0/items"
  "carts" : _ : _           -> "/carts/0"
  "users" : _               -> "/users/0"
  ["login"]                 -> "/login"
  ["checkout"]              -> "/checkout"
  _ -> error "FAIL! UNKNOWN REQUEST FOR EXAMPLE!"

recordMiddleware :: Recorder -> Wai.Application -> Wai.Application
recordMiddleware recorder waiApp req sendResponse
  = record recorder (toKey req) $! waiApp req $ \res -> sendResponse res

getASocket :: Maybe Port -> IO (Port, Socket)
getASocket = \case
  Just port -> do s <- N.socket N.AF_INET N.Stream N.defaultProtocol
                  localhost <- N.inet_addr "127.0.0.1"
                  N.bind s (N.SockAddrInet (fromIntegral port) localhost)
                  N.listen s 1000
                  return (port, s)

  Nothing   -> openFreePort

start :: Maybe Port -> RootInt -> IO ( Port
                                     , Immortal.Thread
                                     , ThreadId
                                     , NextRef AllStats
                                     )
start mport dist = do
  (port, socket) <- getASocket mport

  (ref, recorderThread, recorder) <- newStandaloneRecorder
  scottyApp <- Scotty.scottyApp $ app dist port
  threadId <- flip forkFinally (\_ -> N.close socket)
            $ Warp.runSettingsSocket defaultSettings socket
            $ recordMiddleware recorder
            $ scottyApp

  return (port, recorderThread, threadId, ref)

main :: IO ()
main = do
  xs <- getArgs
  let delay = maybe 0 read $ listToMaybe xs
  (port, socket) <- getASocket $ Just 3000

  (ref, recorderThread, recorder) <- newStandaloneRecorder
  scottyApp <- Scotty.scottyApp $ app (pure delay) port

  (Warp.runSettingsSocket defaultSettings socket
                                        $ recordMiddleware recorder
                                        $ scottyApp) `finally`
    ( do N.close socket
         Immortal.stop recorderThread
         allStats <- NextRef.readLast ref
         putStrLn $ Wrecker.pprStats Nothing Path allStats
    )