diff options
Diffstat (limited to 'verve-wireless/main.hs')
| -rwxr-xr-x | verve-wireless/main.hs | 219 |
1 files changed, 219 insertions, 0 deletions
diff --git a/verve-wireless/main.hs b/verve-wireless/main.hs new file mode 100755 index 0000000..9e9fb56 --- /dev/null +++ b/verve-wireless/main.hs @@ -0,0 +1,219 @@ +#!/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 ixset + --package split + --package conduit + --package conduit-extra +-} + + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + +import Control.Exception (bracket) +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) +import Data.Acid.Advanced (groupUpdates) +import Data.Acid.Local (createCheckpointAndClose) +import Data.Acid +import Data.Conduit +import qualified Data.Conduit.Text as CT +import Data.Conduit.Binary (sourceFile) +import qualified Data.Conduit.List as CL +import Data.Data (Data, Typeable) +import Data.IxSet (Indexable(..), IxSet(..), (@=), Proxy(..), getOne, ixFun, ixSet) +import qualified Data.IxSet as IxSet +import Data.List.Split (splitOn) +import Data.SafeCopy +import qualified Data.Text as T +import Data.Text (Text, pack, unpack) +import Data.Text.Encoding (decodeUtf8) +import qualified Data.Vector as V +import qualified Data.Vector.Generic as GV +import qualified Data.Vector.Generic.Mutable as GMV +import GHC.Generics +import Yesod hiding (Update, update, get) + +newtype BusinessId = BusinessId { unBusinessId :: Int } + deriving (Show, Eq, Enum, Ord, Data, Typeable, Generic) + +$(deriveSafeCopy 0 'base ''BusinessId) + +instance ToJSON BusinessId where + toJSON BusinessId{..} = toJSON unBusinessId + +instance FromJSON BusinessId + +data Business = Business + { businessId :: BusinessId + , name :: Text + , address :: Text + , city :: Text + , state :: Text + , postalCode :: Text + , country :: Text + , latitude :: Double + , longitude :: Double + } + deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) + +$(deriveSafeCopy 0 'base ''Business) + +newtype Name = Name Text deriving (Eq, Ord, Data, Typeable) +newtype Address = Address Text deriving (Eq, Ord, Data, Typeable) +newtype City = City Text deriving (Eq, Ord, Data, Typeable) +newtype State = State Text deriving (Eq, Ord, Data, Typeable) +newtype PostalCode = PostalCode Text deriving (Eq, Ord, Data, Typeable) +newtype Country = Country Text deriving (Eq, Ord, Data, Typeable) +newtype Latitude = Latitude Double deriving (Eq, Ord, Data, Typeable) +newtype Longitude = Longitude Double deriving (Eq, Ord, Data, Typeable) + +$(deriveSafeCopy 0 'base ''Name) +$(deriveSafeCopy 0 'base ''Address) +$(deriveSafeCopy 0 'base ''City) +$(deriveSafeCopy 0 'base ''State) +$(deriveSafeCopy 0 'base ''PostalCode) +$(deriveSafeCopy 0 'base ''Country) +$(deriveSafeCopy 0 'base ''Latitude) +$(deriveSafeCopy 0 'base ''Longitude) + +instance Indexable Business where + empty = ixSet [ ixFun $ \b -> [ Name $ name b ] + , ixFun $ \b -> [ Address $ address b ] + , ixFun $ \b -> [ City $ city b ] + , ixFun $ \b -> [ State $ state b ] + , ixFun $ \b -> [ PostalCode $ postalCode b ] + , ixFun $ \b -> [ Country $ country b ] + , ixFun $ \b -> [ Latitude $ latitude b ] + , ixFun $ \b -> [ Longitude $ longitude b ] + ] + +data Database = Database + { nextBusinessId :: BusinessId + , businesses :: IxSet Business + } + deriving (Typeable) + +instance Data Database +$(deriveSafeCopy 0 'base ''Database) + +initDatabase :: Database +initDatabase = Database + { nextBusinessId = BusinessId 1 -- ^ Index starting at 1 + , businesses = empty + } + +data AddBusinessData = AddBusinessData + { _name :: Text + , _address :: Text + , _city :: Text + , _state :: Text + , _postalCode :: Text + , _country :: Text + , _latitude :: Double + , _longitude :: Double + } + +addBusiness :: AddBusinessData -> Update Database Business +addBusiness AddBusinessData{..} = do + db@Database{..} <- get + let b = Business { businessId = nextBusinessId + , name = _name + , address = _address + , city = _city + , state = _state + , postalCode = _postalCode + , country = _country + , latitude = _latitude + , longitude = _longitude + } + put $ db { nextBusinessId = succ nextBusinessId + , businesses = IxSet.insert b businesses + } + return b + +$(makeAcidic ''Database []) + +mkYesod "App" [parseRoutes|/upload UploadR GET POST|] + +data App = App + { appState :: AcidState Database + } + +instance Yesod App + +instance RenderMessage App FormMessage where + renderMessage _ _ = defaultFormMessage + +uploadForm = renderDivs $ fileAFormReq "File: " + +getUploadR = do + ((_, widget), enctype) <- runFormPost uploadForm + defaultLayout [whamlet| +<p>Upload "offers_poi.tsv" here: +<form method=post enctype=#{enctype}> + ^{widget} + <br> + <input type=submit> +|] + + +-- toBusinessData = map AddBusinessData . map (splitOn "\t") . lines + +postUploadR = do + ((result, widget), enctype) <- runFormPost uploadForm + let mFile = case result of + FormSuccess res -> Just res + _ -> Nothing + defaultLayout $ do + [whamlet| +$maybe f <- mFile + <p>File received: #{fileName f} +<p>Upload "offers_poi.tsv" here: +<form method=post enctype=#{enctype}> + ^{widget} + <br> + <input type=submit> +|] + +main = do + bracket + (openLocalState initDatabase) + (createCheckpointAndClose) + (\db -> do + putStrLn "Ready" + warp 3000 (App db)) + + + +-- TSV File utils +-------------------- + + +readTsvFile :: _ +readTsvFile fp = runConduitRes + $ sourceFile fp + .| CT.decode CT.utf8 + .| CT.lines + .| CL.map (T.split (=='\t')) |