path: root/main.hs

#!/usr/bin/env stack
{- stack
     --nix
     --resolver lts-10.3
     --install-ghc
     runghc
     --package http-types
     --package yesod
     --package yesod-core
     --package text
     --package aeson
     --package acid-state
     --package cassava
     --package ixset
-}

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}

import Data.Acid
import Data.Acid.Local (createCheckpointAndClose)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Csv as Csv
import Data.IxSet (Indexable(..), IxSet(..), (@=), Proxy(..), getOne, ixFun, ixSet)
import qualified Data.IxSet as IxSet
import Data.SafeCopy
import Data.Semigroup
import qualified Data.Vector as Vector
import Data.Data (Data, Typeable)
import GHC.Generics
import Control.Exception (bracket)
import Control.Monad
import Control.Monad.Reader (ask)
import Control.Monad.State (get, put)
import Data.Maybe (isJust)
import Data.Text (Text, pack, unpack)
import Yesod hiding (Number, Update, update, get)
import Network.HTTP.Types.Status (status400, status200)
import Data.Aeson hiding (Number)

--------------------------------------------------------------------
-- | Here be the state and data model stuff.


-- | Wrap a regular Int for CallerId, so we can track unique callers.
newtype CallerId = CallerId { unCallerId :: Int }
  deriving (Show, Eq, Ord, Data, Enum, Typeable, Generic)

$(deriveSafeCopy 0 'base ''CallerId)
instance ToJSON CallerId where
  toJSON CallerId{..} = toJSON unCallerId

instance FromJSON CallerId


-- | A type to describe the shape of our core model
data Caller = Caller
  { callerId :: CallerId
  , name :: Text
  , number :: Text
  , context :: Text
  }
  deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON)

$(deriveSafeCopy 0 'base ''Caller)

-- | Create reified types for each field we want to query

newtype Name = Name Text deriving (Eq, Ord, Data, Typeable)
newtype PhoneNumber = PhoneNumber Text deriving (Eq, Ord, Data, Typeable)
newtype Context = Context Text deriving (Eq, Ord, Data, Typeable)

$(deriveSafeCopy 0 'base ''Name)
$(deriveSafeCopy 0 'base ''PhoneNumber)
$(deriveSafeCopy 0 'base ''Context)

-- | Create the composite index

instance Indexable Caller where
  empty = ixSet [ ixFun $ (:[]) . callerId
                , ixFun $ \c -> [ Name $ name c ]
                , ixFun $ \c -> [ PhoneNumber $ number c ]
                , ixFun $ \c -> [ Context $ context c ]
                ]

-- | The database is a set of @Caller@ records, plus a record counter, so we
-- know the next CallerId to use.
data Database = Database
  { nextCallerId :: CallerId
  , callers :: IxSet Caller
  }
  deriving (Typeable)

instance Data Database
$(deriveSafeCopy 0 'base ''Database)

initDatabase :: Database
initDatabase =
  Database
  { nextCallerId = CallerId 1 -- ^ Index starting a 1
  , callers = empty
  }

---------------------------------------------------------------------------------
-- | CRUD operations on the state


-- | Insert the caller into database.
addCaller :: Text -> Text -> Text -> Update Database Caller
addCaller name number context = do
  db@Database{..} <- get
  let caller = Caller { callerId = nextCallerId
                      , name = name
                      , number = number
                      , context = context }
  put $ db { nextCallerId = succ nextCallerId
           , callers = IxSet.insert caller callers
           }
  return caller

-- | Return a list of the callers
viewCallers :: Int -> Query Database [Caller]
viewCallers limit = do
  Database{..} <- ask
  return $ take limit $ IxSet.toList callers

-- | Update a single caller record
updateCaller :: Caller -> Update Database ()
updateCaller updatedCaller =
  do db@Database{..} <- get
     put $ db { callers = IxSet.updateIx (callerId updatedCaller) updatedCaller callers }

-- | Lookup caller by CallerId
callerById :: CallerId -> Query Database (Maybe Caller)
callerById cid =
  do Database{..} <- ask
     return $ getOne $ callers @= cid

-- | Lookup caller by PhoneNumber
callerByNumber :: PhoneNumber -> Query Database [Caller]
callerByNumber num =
  do Database{..} <- ask
     return $ IxSet.toList $ callers @= num

countCallers :: Query Database Int
countCallers =
  do Database{..} <- ask
     return $ IxSet.size callers

$(makeAcidic ''Database
  ['addCaller
  , 'updateCaller
  , 'callerById
  , 'callerByNumber
  , 'viewCallers
  , 'countCallers
  ])


-----------------------------------------------------------------------
-- | Here be the HTTP stuff

data App = App
  { appState :: AcidState Database
  }

mkYesod "App" [parseRoutes|
/bootstrap BootstrapR POST
/query QueryR GET
/count CountR GET
/number NumberR POST
|]

-- | Initiate Yesod. The default method instances are fine for a prototype or
-- demo app.
instance Yesod App

data ApiError = ApiError
  { msg :: Text
  }
  deriving (Show, Eq, Generic, ToJSON, FromJSON)

getQueryR :: Handler RepJson
getQueryR = do
  qm <- lookupGetParam "number"
  case qm of
    Nothing -> do
      app <- getYesod
      let db = appState app
      callers <- liftIO $ query db $ ViewCallers 20
      sendStatusJSON status200 $ object [ "results" .= callers ]

    Just q -> do
      app <- getYesod
      let db = appState app
      caller <- liftIO $ query db $ CallerByNumber $ PhoneNumber q
      sendStatusJSON status200 $ object [ "results" .= caller ]

getCountR :: Handler RepJson
getCountR = do
  app <- getYesod
  let db = appState app
  n <- liftIO $ query db $ CountCallers
  sendStatusJSON status200 $ object [ "count" .= n ]

data PostRequest = PostRequest
  { _name :: Text
  , _number :: Text
  , _context :: Text
  }
  deriving (Show, Eq, Generic)

instance FromJSON PostRequest where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 1 }

instance ToJSON PostRequest where
  toJSON = genericToJSON defaultOptions { fieldLabelModifier = drop 1 }


postNumberR :: Handler RepJson
postNumberR = do
  (obj :: Result PostRequest) <- parseJsonBody
  case obj of
    Error err ->
      sendStatusJSON status400 $ ApiError $ "Invalid request. Could not parse JSON body: " <> pack err

    Success PostRequest{..} -> do
      app <- getYesod
      let db = appState app
      caller <- liftIO $ update db $ AddCaller _name _number _context
      sendStatusJSON status200 $ caller

-- | This takes a while; on my machine it averages 181 records per second. It's
-- IO bound, and in an un-optimized program GHC on Linux uses a single, blocking
-- IO manager thread (on Windows it's non-blocking, apparently). This can be
-- improved with the Control.Concurrent module, it which case we could launch as
-- many IO threads as we want, and do probably 10k records per second. There's
-- definitely an optimal amount of threads here, we'd have to test to find that.
--
-- HOWEVER, you can watch it bootstrap. Hit this endpoint, then use "GET /count"
-- to see it updating. New POSTs will also work and update the database, even
-- while it is bootstrapping, which is kinda cool.
--
-- Try this in bash:
--
--    while sleep 1; do curl -s "localhost:3000/count" | jq '.count'; done
--
postBootstrapR :: Handler RepJson
postBootstrapR = do
  $logInfo "Initializing the database."
  app <- getYesod
  let db = appState app
  $logInfo "Loading data from CSV."
  seedData <- liftIO $ BSL.readFile "interview-callerid-data.csv"
  callers <- case Csv.decode Csv.NoHeader seedData of
         Left err -> fail err
         Right v ->
           Vector.forM_ (Vector.indexed v) $ \(callerId, record) -> do
           let (number, context, name) = record
           c <- liftIO $ update db $ AddCaller name number context
           return c
  sendStatusJSON status200 $ ("Bootstrap complete." :: Text)


-- | Start a simple warp server on 3000
main :: IO ()
main = do
  bracket (openLocalState initDatabase)
          (createCheckpointAndClose)
          (\db -> do
              putStrLn "Ready"
              warp 3000 (App db))