533 lines
13 KiB
Haskell
533 lines
13 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
|
|
module Owner where
|
|
|
|
import Data.Aeson
|
|
import qualified Data.Bson as B
|
|
import Data.Maybe
|
|
import qualified Data.Text as T
|
|
import Data.Time.Clock
|
|
import Data.Typeable
|
|
import Database.MongoDB
|
|
import GHC.Generics
|
|
|
|
-- | Type to represent a ZGo shop owner/business
|
|
data Owner = Owner
|
|
{ o_id :: Maybe ObjectId
|
|
, oaddress :: T.Text
|
|
, oname :: T.Text
|
|
, ocurrency :: T.Text
|
|
, otax :: Bool
|
|
, otaxValue :: Double
|
|
, ovat :: Bool
|
|
, ovatValue :: Double
|
|
, ofirst :: T.Text
|
|
, olast :: T.Text
|
|
, oemail :: T.Text
|
|
, ostreet :: T.Text
|
|
, ocity :: T.Text
|
|
, ostate :: T.Text
|
|
, opostal :: T.Text
|
|
, ophone :: T.Text
|
|
, owebsite :: T.Text
|
|
, ocountry :: T.Text
|
|
, opaid :: Bool
|
|
, ozats :: Bool
|
|
, oinvoices :: Bool
|
|
, oexpiration :: UTCTime
|
|
, opayconf :: Bool
|
|
, oviewkey :: T.Text
|
|
, ocrmToken :: T.Text
|
|
, otips :: Bool
|
|
} deriving (Eq, Show, Generic, Typeable)
|
|
|
|
instance ToJSON Owner where
|
|
toJSON (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv eTs pc vk cT oT) =
|
|
case i of
|
|
Just oid ->
|
|
object
|
|
[ "_id" .= show oid
|
|
, "address" .= a
|
|
, "name" .= n
|
|
, "currency" .= c
|
|
, "tax" .= t
|
|
, "taxValue" .= tV
|
|
, "vat" .= v
|
|
, "vatValue" .= vV
|
|
, "first" .= f
|
|
, "last" .= l
|
|
, "email" .= e
|
|
, "street" .= s
|
|
, "city" .= ct
|
|
, "state" .= st
|
|
, "postal" .= p
|
|
, "phone" .= ph
|
|
, "website" .= w
|
|
, "country" .= co
|
|
, "paid" .= paid
|
|
, "zats" .= zats
|
|
, "invoices" .= inv
|
|
, "expiration" .= eTs
|
|
, "payconf" .= pc
|
|
, "viewkey" .= vk
|
|
, "crmToken" .= cT
|
|
, "tips" .= oT
|
|
]
|
|
Nothing ->
|
|
object
|
|
[ "_id" .= ("" :: String)
|
|
, "address" .= a
|
|
, "name" .= n
|
|
, "currency" .= c
|
|
, "tax" .= t
|
|
, "taxValue" .= tV
|
|
, "vat" .= v
|
|
, "vatValue" .= vV
|
|
, "first" .= f
|
|
, "last" .= l
|
|
, "email" .= e
|
|
, "street" .= s
|
|
, "city" .= ct
|
|
, "state" .= st
|
|
, "postal" .= p
|
|
, "phone" .= ph
|
|
, "website" .= w
|
|
, "country" .= co
|
|
, "paid" .= paid
|
|
, "zats" .= zats
|
|
, "invoices" .= inv
|
|
, "expiration" .= eTs
|
|
, "payconf" .= pc
|
|
, "viewkey" .= vk
|
|
, "crmToken" .= cT
|
|
, "tips" .= oT
|
|
]
|
|
|
|
instance FromJSON Owner where
|
|
parseJSON =
|
|
withObject "Owner" $ \obj -> do
|
|
i <- obj .: "_id"
|
|
a <- obj .: "address"
|
|
n <- obj .: "name"
|
|
c <- obj .: "currency"
|
|
t <- obj .: "tax"
|
|
tV <- obj .: "taxValue"
|
|
v <- obj .: "vat"
|
|
vV <- obj .: "vatValue"
|
|
f <- obj .: "first"
|
|
l <- obj .: "last"
|
|
e <- obj .: "email"
|
|
s <- obj .: "street"
|
|
ct <- obj .: "city"
|
|
st <- obj .: "state"
|
|
p <- obj .: "postal"
|
|
ph <- obj .: "phone"
|
|
w <- obj .: "website"
|
|
co <- obj .: "country"
|
|
paid <- obj .: "paid"
|
|
zats <- obj .: "zats"
|
|
inv <- obj .: "invoices"
|
|
ets <- obj .: "expiration"
|
|
pc <- obj .:? "payconf"
|
|
vk <- obj .:? "viewkey"
|
|
cT <- obj .:? "crmToken"
|
|
oT <- obj .:? "tips"
|
|
pure $
|
|
Owner
|
|
(if not (null i)
|
|
then Just (read i)
|
|
else Nothing)
|
|
a
|
|
n
|
|
c
|
|
t
|
|
tV
|
|
v
|
|
vV
|
|
f
|
|
l
|
|
e
|
|
s
|
|
ct
|
|
st
|
|
p
|
|
ph
|
|
w
|
|
co
|
|
paid
|
|
zats
|
|
inv
|
|
ets
|
|
(fromMaybe False pc)
|
|
(fromMaybe "" vk)
|
|
(fromMaybe "" cT)
|
|
(fromMaybe False oT)
|
|
|
|
instance Val Owner where
|
|
cast' (Doc d) = do
|
|
i <- B.lookup "_id" d
|
|
a <- B.lookup "address" d
|
|
n <- B.lookup "name" d
|
|
c <- B.lookup "currency" d
|
|
t <- B.lookup "tax" d
|
|
tV <- B.lookup "taxValue" d
|
|
v <- B.lookup "vat" d
|
|
vV <- B.lookup "vatValue" d
|
|
f <- B.lookup "first" d
|
|
l <- B.lookup "last" d
|
|
e <- B.lookup "email" d
|
|
s <- B.lookup "street" d
|
|
ct <- B.lookup "city" d
|
|
st <- B.lookup "state" d
|
|
p <- B.lookup "postal" d
|
|
ph <- B.lookup "phone" d
|
|
w <- B.lookup "website" d
|
|
co <- B.lookup "country" d
|
|
paid <- B.lookup "paid" d
|
|
zats <- B.lookup "zats" d
|
|
inv <- B.lookup "invoices" d
|
|
ets <- B.lookup "expiration" d
|
|
pc <- B.lookup "payconf" d
|
|
vk <- B.lookup "viewKey" d
|
|
cT <- B.lookup "crmToken" d
|
|
oT <- B.lookup "tips" d
|
|
Just
|
|
(Owner
|
|
i
|
|
a
|
|
n
|
|
c
|
|
t
|
|
tV
|
|
v
|
|
vV
|
|
f
|
|
l
|
|
e
|
|
s
|
|
ct
|
|
st
|
|
p
|
|
ph
|
|
w
|
|
co
|
|
paid
|
|
zats
|
|
inv
|
|
ets
|
|
pc
|
|
vk
|
|
cT
|
|
oT)
|
|
cast' _ = Nothing
|
|
val (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv ets pc vk cT oT) =
|
|
case i of
|
|
Just oid ->
|
|
Doc
|
|
[ "_id" =: oid
|
|
, "address" =: a
|
|
, "name" =: n
|
|
, "currency" =: c
|
|
, "tax" =: t
|
|
, "taxValue" =: tV
|
|
, "vat" =: v
|
|
, "vatValue" =: vV
|
|
, "first" =: f
|
|
, "last" =: l
|
|
, "email" =: e
|
|
, "street" =: s
|
|
, "city" =: ct
|
|
, "state" =: st
|
|
, "postal" =: p
|
|
, "phone" =: ph
|
|
, "website" =: w
|
|
, "country" =: co
|
|
, "paid" =: paid
|
|
, "zats" =: zats
|
|
, "invoices" =: inv
|
|
, "expiration" =: ets
|
|
, "payconf" =: pc
|
|
, "viewKey" =: vk
|
|
, "crmToken" =: cT
|
|
, "tips" =: oT
|
|
]
|
|
Nothing ->
|
|
Doc
|
|
[ "address" =: a
|
|
, "name" =: n
|
|
, "currency" =: c
|
|
, "tax" =: t
|
|
, "taxValue" =: tV
|
|
, "vat" =: v
|
|
, "vatValue" =: vV
|
|
, "first" =: f
|
|
, "last" =: l
|
|
, "email" =: e
|
|
, "street" =: s
|
|
, "city" =: ct
|
|
, "state" =: st
|
|
, "postal" =: p
|
|
, "phone" =: ph
|
|
, "website" =: w
|
|
, "country" =: co
|
|
, "paid" =: paid
|
|
, "zats" =: zats
|
|
, "invoices" =: inv
|
|
, "expiration" =: ets
|
|
, "payconf" =: pc
|
|
, "viewKey" =: vk
|
|
, "crmToken" =: cT
|
|
, "tips" =: oT
|
|
]
|
|
|
|
-- | Type to represent informational data for Owners from UI
|
|
data OwnerData = OwnerData
|
|
{ od_first :: T.Text
|
|
, od_last :: T.Text
|
|
, od_name :: T.Text
|
|
, od_street :: T.Text
|
|
, od_city :: T.Text
|
|
, od_state :: T.Text
|
|
, od_postal :: T.Text
|
|
, od_country :: T.Text
|
|
, od_email :: T.Text
|
|
, od_website :: T.Text
|
|
, od_phone :: T.Text
|
|
} deriving (Eq, Show, Generic)
|
|
|
|
instance FromJSON OwnerData where
|
|
parseJSON =
|
|
withObject "OwnerData" $ \obj -> do
|
|
f <- obj .: "first"
|
|
l <- obj .: "last"
|
|
n <- obj .: "name"
|
|
s <- obj .: "street"
|
|
c <- obj .: "city"
|
|
st <- obj .: "state"
|
|
p <- obj .: "postal"
|
|
co <- obj .: "country"
|
|
e <- obj .: "email"
|
|
w <- obj .: "website"
|
|
ph <- obj .: "phone"
|
|
pure $ OwnerData f l n s c st p co e w ph
|
|
|
|
data OwnerSettings = OwnerSettings
|
|
{ os_id :: Maybe ObjectId
|
|
, os_address :: T.Text
|
|
, os_name :: T.Text
|
|
, os_currency :: T.Text
|
|
, os_tax :: Bool
|
|
, os_taxValue :: Double
|
|
, os_vat :: Bool
|
|
, os_vatValue :: Double
|
|
, os_paid :: Bool
|
|
, os_zats :: Bool
|
|
, os_invoices :: Bool
|
|
, os_expiration :: UTCTime
|
|
, os_payconf :: Bool
|
|
, os_crmToken :: T.Text
|
|
, os_viewKey :: T.Text
|
|
, os_tips :: Bool
|
|
} deriving (Eq, Show, Generic)
|
|
|
|
instance FromJSON OwnerSettings where
|
|
parseJSON =
|
|
withObject "OwnerSettings" $ \obj -> do
|
|
i <- obj .:? "_id"
|
|
a <- obj .: "address"
|
|
n <- obj .: "name"
|
|
c <- obj .: "currency"
|
|
t <- obj .: "tax"
|
|
tV <- obj .: "taxValue"
|
|
v <- obj .: "vat"
|
|
vV <- obj .: "vatValue"
|
|
p <- obj .: "paid"
|
|
z <- obj .: "zats"
|
|
inv <- obj .: "invoices"
|
|
e <- obj .: "expiration"
|
|
pc <- obj .: "payconf"
|
|
cT <- obj .: "crmToken"
|
|
vK <- obj .: "viewkey"
|
|
oT <- obj .: "tips"
|
|
pure $
|
|
OwnerSettings
|
|
((Just . read) =<< i)
|
|
a
|
|
n
|
|
c
|
|
t
|
|
tV
|
|
v
|
|
vV
|
|
p
|
|
z
|
|
inv
|
|
e
|
|
pc
|
|
cT
|
|
vK
|
|
oT
|
|
|
|
instance ToJSON OwnerSettings where
|
|
toJSON (OwnerSettings i a n c t tV v vV p z inv e pc cT vK oT) =
|
|
object
|
|
[ "_id" .= maybe "" show i
|
|
, "address" .= a
|
|
, "name" .= n
|
|
, "currency" .= c
|
|
, "tax" .= t
|
|
, "taxValue" .= tV
|
|
, "vat" .= v
|
|
, "vatValue" .= vV
|
|
, "paid" .= p
|
|
, "zats" .= z
|
|
, "invoices" .= inv
|
|
, "expiration" .= e
|
|
, "payconf" .= pc
|
|
, "crmToken" .= cT
|
|
, "viewkey" .= keyObfuscate vK
|
|
, "tips" .= oT
|
|
]
|
|
where
|
|
keyObfuscate s
|
|
| s == "" = ""
|
|
| otherwise = T.take 8 s <> "...." <> T.takeEnd 8 s
|
|
|
|
-- Helper Functions
|
|
getOwnerSettings :: Owner -> OwnerSettings
|
|
getOwnerSettings o =
|
|
OwnerSettings
|
|
(o_id o)
|
|
(oaddress o)
|
|
(oname o)
|
|
(ocurrency o)
|
|
(otax o)
|
|
(otaxValue o)
|
|
(ovat o)
|
|
(ovatValue o)
|
|
(opaid o)
|
|
(ozats o)
|
|
(oinvoices o)
|
|
(oexpiration o)
|
|
(opayconf o)
|
|
(ocrmToken o)
|
|
(oviewkey o)
|
|
(otips o)
|
|
|
|
-- Database actions
|
|
-- | Function to upsert an Owner
|
|
upsertOwner :: Owner -> Action IO ()
|
|
upsertOwner o = do
|
|
let owner = val o
|
|
case owner of
|
|
Doc d -> upsert (select ["address" =: oaddress o] "owners") d
|
|
_ -> return ()
|
|
|
|
-- | Function to get an Owner
|
|
findOwner :: T.Text -> Action IO (Maybe Document)
|
|
findOwner zaddy = findOne (select ["address" =: zaddy] "owners")
|
|
|
|
-- | Function to get an Owner by id
|
|
findOwnerById :: T.Text -> Action IO (Maybe Document)
|
|
findOwnerById i =
|
|
findOne (select ["_id" =: (read (T.unpack i) :: ObjectId)] "owners")
|
|
|
|
findActiveOwners :: Action IO [Document]
|
|
findActiveOwners =
|
|
rest =<< find (select ["paid" =: True, "payconf" =: True] "owners")
|
|
|
|
-- | Function to find Owners about to expire
|
|
findExpiringOwners :: UTCTime -> Action IO [Document]
|
|
findExpiringOwners now =
|
|
rest =<<
|
|
find
|
|
(select
|
|
["paid" =: True, "expiration" =: ["$lte" =: addUTCTime 172800 now]]
|
|
"owners")
|
|
|
|
findWithKeys :: Action IO [Document]
|
|
findWithKeys =
|
|
rest =<< find (select ["paid" =: True, "payconf" =: True] "owners")
|
|
|
|
removePro :: T.Text -> Action IO ()
|
|
removePro o =
|
|
modify (select ["address" =: o] "owners") ["$set" =: ["invoices" =: False]]
|
|
|
|
updateOwnerSettings :: OwnerSettings -> Action IO ()
|
|
updateOwnerSettings os =
|
|
modify
|
|
(select ["_id" =: os_id os] "owners")
|
|
[ "$set" =:
|
|
[ "name" =: os_name os
|
|
, "currency" =: os_currency os
|
|
, "tax" =: os_tax os
|
|
, "taxValue" =: os_taxValue os
|
|
, "vat" =: os_vat os
|
|
, "vatValue" =: os_vatValue os
|
|
, "zats" =: os_zats os
|
|
, "payconf" =: os_payconf os
|
|
, "crmToken" =: os_crmToken os
|
|
, "tips" =: os_tips os
|
|
]
|
|
]
|
|
|
|
upsertViewingKey :: Owner -> String -> Action IO ()
|
|
upsertViewingKey o vk =
|
|
modify (select ["_id" =: o_id o] "owners") ["$set" =: ["viewKey" =: vk]]
|
|
|
|
-- | Type for a pro session
|
|
data ZGoProSession = ZGoProSession
|
|
{ ps_id :: Maybe ObjectId
|
|
, psaddress :: T.Text
|
|
, psexpiration :: UTCTime
|
|
, psclosed :: Bool
|
|
} deriving (Eq, Show)
|
|
|
|
instance Val ZGoProSession where
|
|
cast' (Doc d) = do
|
|
i <- B.lookup "_id" d
|
|
a <- B.lookup "address" d
|
|
e <- B.lookup "expiration" d
|
|
p <- B.lookup "closed" d
|
|
Just (ZGoProSession i a e p)
|
|
cast' _ = Nothing
|
|
val (ZGoProSession i a e p) =
|
|
case i of
|
|
Just oid ->
|
|
Doc ["_id" =: oid, "address" =: a, "expiration" =: e, "closed" =: p]
|
|
Nothing -> Doc ["address" =: a, "expiration" =: e, "closed" =: p]
|
|
|
|
-- | Function to get a pro session
|
|
findProSession :: T.Text -> Action IO (Maybe Document)
|
|
findProSession zaddy =
|
|
findOne (select ["address" =: zaddy, "closed" =: False] "prosessions")
|
|
|
|
-- | Function to get expiring pro sessions
|
|
findExpiringProSessions :: UTCTime -> Action IO [Document]
|
|
findExpiringProSessions now =
|
|
rest =<<
|
|
find
|
|
(select ["closed" =: False, "expiration" =: ["$lte" =: now]] "prosessions")
|
|
|
|
-- | Function to upsert a pro session
|
|
upsertProSession :: ZGoProSession -> Action IO ()
|
|
upsertProSession ps = do
|
|
let prosession = val ps
|
|
case prosession of
|
|
Doc d ->
|
|
upsert
|
|
(select
|
|
["address" =: psaddress ps, "expiration" =: psexpiration ps]
|
|
"prosessions")
|
|
d
|
|
_ -> return ()
|
|
|
|
closeProSession :: ZGoProSession -> Action IO ()
|
|
closeProSession ps = do
|
|
let prosession = val ps
|
|
case prosession of
|
|
Doc d -> modify (select d "prosessions") ["$set" =: ["closed" =: True]]
|
|
_ -> return ()
|