Index data and implement query functions

Everything is working now, just a bit slow/buggy i think

1 files changed, 124 insertions, 38 deletions

diff --git a/main.hs b/main.hs
index 59c0b50..e4a0b49 100755
--- a/main.hs
+++ b/main.hs
@@ -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))