diff options
Diffstat (limited to 'main.hs')
| -rwxr-xr-x | main.hs | 279 |
1 files changed, 0 insertions, 279 deletions
diff --git a/main.hs b/main.hs deleted file mode 100755 index 8845d3f..0000000 --- a/main.hs +++ /dev/null @@ -1,279 +0,0 @@ -#!/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.Advanced (groupUpdates) -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, isPrefixOf) -import Yesod hiding (Number, Update, update, get) -import Network.HTTP.Types.Status (status400, status200) -import Data.Aeson hiding (Number) - ----------------------------------------------------------------------- --- | Parser for standardizing phone number format - --- To properly implement this, I would use libphonenumber -parsePhoneNumber :: Text -> Text -parsePhoneNumber = countryCode . pack . stripInvalidChars . unpack - where - stripInvalidChars :: String -> String - countryCode :: Text -> Text - stripInvalidChars cs = [ c | c <- cs, not $ elem c (".()- " :: String) ] - countryCode t = if (isPrefixOf "+" t) then t else ("+1" <> t) - --------------------------------------------------------------------- --- | 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 $ parsePhoneNumber $ 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 = parsePhoneNumber 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 - - -callerFromCsv (number, context, name) = AddCaller name number context - -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 -> liftIO $ groupUpdates db $ Vector.toList $ Vector.map callerFromCsv v - 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)) |