1 files changed, 279 insertions, 0 deletions
diff --git a/truly.co/main.hs b/truly.co/main.hs
new file mode 100755
index 0000000..8845d3f
--- /dev/null
+++ b/truly.co/main.hs
@@ -0,0 +1,279 @@
+#!/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))