diff options
Diffstat (limited to 'main.hs')
| -rwxr-xr-x | main.hs | 162 |
1 files changed, 124 insertions, 38 deletions
@@ -11,67 +11,140 @@ --package aeson --package acid-state --package cassava + --package ixset -} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} import Data.Acid +import Data.Acid.Advanced (update', query') +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 hiding (take) -import Yesod hiding (Update, update, get) +import Data.Text (Text, pack, unpack) +import Yesod hiding (Number, Update, update, get) import Network.HTTP.Types.Status (status400, status200) -import Data.Aeson +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 - { name :: Text + { callerId :: CallerId + , name :: Text , number :: Text , context :: Text } - deriving (Show, Eq, Generic, ToJSON, FromJSON) + deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) $(deriveSafeCopy 0 'base ''Caller) --- | The database is just a list of @Caller@ records. -data Database = Database [Caller] +-- | Create indexes 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) + +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) --- | Cons the caller to database. -addCaller :: Caller -> Update Database () -addCaller caller = do - Database callers <- get - put $ Database (caller:callers) +initDatabase :: Database +initDatabase = + Database + { nextCallerId = CallerId 1 -- ^ Index starting a 1 + , callers = empty + } + +-- | 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 --- | Grab a subset of the caller list. viewCallers :: Int -> Query Database [Caller] viewCallers limit = do - Database callers <- ask - return $ take limit callers + 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 + +callerByNumber :: PhoneNumber -> Query Database [Caller] +callerByNumber num = + do Database{..} <- ask + return $ IxSet.toList $ callers @= num --- | This generates @AddCaller@ and @ViewCallers@ types automatically. -$(makeAcidic ''Database ['addCaller, 'viewCallers]) +$(makeAcidic ''Database ['addCaller, 'updateCaller, 'callerById, 'callerByNumber, 'viewCallers]) ----------------------------------------------------------------------- -- | Here be the HTTP stuff @@ -94,9 +167,6 @@ data ApiError = ApiError } deriving (Show, Eq, Generic, ToJSON, FromJSON) --- FIXME -findByNumber = id - getQueryR :: Handler RepJson getQueryR = do qm <- lookupGetParam "number" @@ -104,41 +174,57 @@ getQueryR = do Nothing -> do app <- getYesod let db = appState app - callers <- liftIO $ query db (ViewCallers 20) - sendStatusJSON status400 $ callers + callers <- query' db $ ViewCallers 20 + sendStatusJSON status200 $ object [ "results" .= callers ] Just q -> do app <- getYesod let db = appState app - sendStatusJSON status200 $ object [ "msg" .= ("FIXME" :: Text) ] + caller <- query' db $ CallerByNumber $ PhoneNumber q + $logInfo $ pack $ show caller + sendStatusJSON status200 $ object [ "results" .= caller ] + +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 Caller) <- parseJsonBody + (obj :: Result PostRequest) <- parseJsonBody case obj of Error err -> sendStatusJSON status400 $ ApiError $ "Invalid request. Could not parse JSON body: " <> pack err - Success caller -> do + Success PostRequest{..} -> do app <- getYesod let db = appState app - liftIO $ update db $ AddCaller caller + caller <- liftIO $ update db $ AddCaller _name _number _context sendStatusJSON status200 $ caller +mapIndexed f l = zipWith f l [0..] -- | Start a simple warp server on 3000 main :: IO () main = do - seedData <- BSL.readFile "seed.csv" - database <- openLocalStateFrom "database/" (Database []) - case Csv.decode Csv.NoHeader seedData of - Left err -> - fail err - - Right v -> - Vector.forM_ v $ \(number, context, name) -> do - update database $ AddCaller $ Caller name number context - putStrLn $ unpack $ name <> number <> context - - warp 3000 (App database) + bracket (openLocalState initDatabase) + (createCheckpointAndClose) + (\db -> do + seedData <- BSL.readFile "interview-callerid-data.csv" + 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 + update' db $ UpdateCaller $ Caller (CallerId callerId) name number context + putStrLn "Ready" + warp 3000 (App db)) |