Create.purs
module Aftok.Billing.Create where
import Prelude
import Aftok.Api.Billing (BillableId, Billable, Recurrence(..), createBillable)
import Aftok.Api.Types (APIError(..))
import Aftok.HTML.Classes as C
import Aftok.Modals.ModalFFI as ModalFFI
import Aftok.Types (System, ProjectId)
import Aftok.Zcash (ZEC(..), toZatoshi, ZPrec)
import Control.Monad.Trans.Class (lift)
import Data.Either (Either(..), note)
import Data.Fixed as Fixed
import Data.Foldable (any)
import Data.Int as Int
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Newtype (unwrap)
import Data.Number (fromString) as Number
import Data.Number.Format (toString) as Number
import Data.Time.Duration (Hours(..), Days(..))
import Data.Tuple (Tuple(..))
import Data.Validation.Semigroup (V(..), toEither)
import Effect.Aff (Aff)
import DOM.HTML.Indexed.ButtonType (ButtonType(..))
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Core (ClassName(..))
import Halogen.HTML.Events as E
import Halogen.HTML.Properties as P
import Halogen.HTML.Properties.ARIA as ARIA
data Field
= PidField
| NameField
| DescField
| MessageField
| MonthlyRecurrenceField
| WeeklyRecurrenceField
| AmountField
| GracePeriodField
| RequestExpiryField
derive instance fieldEq :: Eq Field
derive instance fieldOrd :: Ord Field
data RType
= RTAnnual
| RTMonthly
| RTWeekly
| RTOneTime
derive instance rtypeEq :: Eq RType
type CState =
{ projectId :: Maybe ProjectId
, name :: Maybe String
, description :: Maybe String
, message :: Maybe String
, recurrenceType :: RType
, recurrenceValue :: Maybe Int
, amount :: Maybe String
, gracePeriod :: Maybe Days
, requestExpiry :: Maybe Hours
, fieldErrors :: Array Field
}
data Query a
= OpenModal ProjectId a
data Output
= BillableCreated BillableId
data Action
= SetName String
| SetDesc String
| SetMessage String
| SetRecurrenceType RType
| SetRecurrenceMonths String
| SetRecurrenceWeeks String
| SetBillingAmount String
| SetGracePeriod String
| SetRequestExpiry String
| Save
| Close
type Slot id
= H.Slot Query Output id
type Capability (m :: Type -> Type)
= { createBillable :: ProjectId -> Billable -> m (Either APIError BillableId)
}
modalId :: String
modalId = "createBillable"
component ::
forall input m.
Monad m =>
System m ->
Capability m ->
H.Component HH.HTML Query input Output m
component system caps =
H.mkComponent
{ initialState: const initialState
, render
, eval: H.mkEval
$ H.defaultEval
{ handleAction = handleAction
, handleQuery = handleQuery
}
}
where
initialState :: CState
initialState =
{ projectId: Nothing
, name : Nothing
, description : Nothing
, message : Nothing
, recurrenceType : RTOneTime
, recurrenceValue : Nothing
, amount : Nothing
, gracePeriod : Nothing
, requestExpiry : Nothing
, fieldErrors : []
}
render :: forall slots. CState -> H.ComponentHTML Action slots m
render st =
HH.div
[ P.classes [ C.modal ]
, P.id_ modalId
, P.tabIndex (negate 1)
, ARIA.role "dialog"
, ARIA.labelledBy (modalId <> "Title")
, ARIA.hidden "true"
]
[ HH.div
[ P.classes [C.modalDialog], ARIA.role "document" ]
[ HH.div
[ P.classes [C.modalContent] ]
[ HH.div
[ P.classes [C.modalHeader] ]
[ HH.h5 [P.classes [C.modalTitle], P.id_ (modalId <>"Title") ] [HH.text "Create a new billable item"]
, HH.button
[ P.classes [ C.close ]
, ARIA.label "Close"
, P.type_ ButtonButton
, E.onClick (\_ -> Just Close)
]
[ HH.span [ARIA.hidden "true"] [HH.text "×"]]
]
, HH.div
[ P.classes [C.modalBody] ]
[ HH.form_
[ formGroup st
[ NameField ]
[ HH.label
[ P.for "billableName"]
[ HH.text "Product Name" ]
, HH.input
[ P.type_ P.InputText
, P.classes [ C.formControl, C.formControlSm ]
, P.id_ "billableName"
, P.placeholder "A name for the product or service you want to bill for"
, E.onValueInput (Just <<< SetName)
]
]
, formGroup st
[ DescField ]
[ HH.label
[ P.for "billableDesc"]
[ HH.text "Product Description" ]
, HH.input
[ P.type_ P.InputText
, P.classes [ C.formControl, C.formControlSm ]
, P.id_ "billableDesc"
, P.placeholder "Description of the product or service"
, E.onValueInput (Just <<< SetDesc)
]
]
, formGroup st
[ MessageField ]
[ HH.label
[ P.for "billableMsg"]
[ HH.text "Message to be included with bill" ]
, HH.input
[ P.type_ P.InputText
, P.classes [C.formControl, C.formControlSm]
, P.id_ "billableMsg"
, P.placeholder "Enter your message here"
, E.onValueInput (Just <<< SetMessage)
]
]
, formGroup st
[MonthlyRecurrenceField, WeeklyRecurrenceField]
[ formCheckGroup
{ id: "recurAnnual"
, checked: (st.recurrenceType == RTAnnual)
, labelClasses: []
}
(\_ -> Just (SetRecurrenceType RTAnnual))
[ HH.text "Annual" ]
, formCheckGroup
{ id: "recurMonthly"
, checked: (st.recurrenceType == RTMonthly)
, labelClasses: [C.formInline]
}
(\_ -> Just (SetRecurrenceType RTMonthly))
[ HH.text "Every"
, HH.input
[ P.type_ P.InputNumber
, P.classes [ C.formControl, C.formControlXs, C.formControlFlush, C.marginX2 ]
, P.value (if st.recurrenceType == RTMonthly
then maybe "" show st.recurrenceValue
else "")
, P.min 1.0
, P.max 12.0
, E.onValueInput (Just <<< SetRecurrenceMonths)
]
, HH.text "Months"]
, formCheckGroup
{ id: "recurWeekly"
, checked: (st.recurrenceType == RTWeekly)
, labelClasses: [C.formInline]
}
(\_ -> Just (SetRecurrenceType RTWeekly))
[ HH.text "Every"
, HH.input
[ P.type_ P.InputNumber
, P.classes [ C.formControl, C.formControlXs, C.formControlFlush, C.marginX2 ]
, P.value (if st.recurrenceType == RTWeekly
then maybe "" show st.recurrenceValue
else "")
, P.min 1.0
, P.max 12.0
, E.onValueInput (Just <<< SetRecurrenceWeeks)
]
, HH.text "Weeks"
]
, formCheckGroup
{ id: "oneTime"
, checked: st.recurrenceType == RTOneTime
, labelClasses: []
}
(\_ -> Just (SetRecurrenceType RTOneTime))
[ HH.text "One-Time" ]
]
, formGroup st
[AmountField]
[ HH.label
[ P.for "billableAmount"]
[ HH.text "Amount" ]
, HH.div
[ P.classes [ ClassName "input-group", ClassName "input-group-sm" ] ]
[ HH.input
[ P.type_ P.InputNumber
, P.classes [ C.formControl ]
, P.id_ "billableAmount"
, P.value (fromMaybe "" st.amount)
, P.placeholder "1.0"
, P.min 0.0
, E.onValueInput (Just <<< SetBillingAmount)
]
, HH.div
[ P.classes [ ClassName "input-group-append"] ]
[ HH.span
[ P.classes [ ClassName "input-group-text" ]
, P.style "height: auto;" -- fix bad calculated height from LandKit
]
[ HH.text "ZEC" ] ]
]
]
, formGroup st
[GracePeriodField]
[ HH.label
[ P.for "gracePeriod"]
[ HH.text "Grace Period (Days)" ]
, HH.input
[ P.type_ P.InputNumber
, P.id_ "gracePeriod"
, P.classes [ C.formControl, C.formControlSm ]
, P.value (maybe "" (Number.toString <<< unwrap) st.gracePeriod)
, P.placeholder "Days until a bill is considered overdue"
, P.min 0.0
, E.onValueInput (Just <<< SetGracePeriod)
]
]
, formGroup st
[RequestExpiryField]
[ HH.label
[ P.for "requestExpiry"]
[ HH.text "Request Expiry Period (Hours)" ]
, HH.input
[ P.type_ P.InputNumber
, P.id_ "gracePeriod"
, P.classes [ C.formControl, C.formControlSm ]
, P.value (maybe "" (Number.toString <<< unwrap) st.requestExpiry)
, P.placeholder "Hours until a payment request expires"
, P.min 0.0
, E.onValueInput (Just <<< SetRequestExpiry)
]
]
]
, formGroup st [PidField] []
]
, HH.div
[ P.classes [C.modalFooter] ]
[ HH.button
[ P.type_ ButtonButton
, P.classes [ C.btn, C.btnSecondary]
, E.onClick (\_ -> Just Close)
]
[ HH.text "Close" ]
, HH.button
[ P.type_ ButtonButton
, P.classes [ C.btn, C.btnPrimary ]
, E.onClick (\_ -> Just Save)
]
[ HH.text "Create billable"]
]
]
]
]
formGroup :: forall i a. CState -> Array Field -> Array (HH.HTML i a) -> HH.HTML i a
formGroup st fields body =
HH.div
[ P.classes [C.formGroup] ]
(body <> (fieldError st =<< fields))
formCheckGroup :: forall i a.
{ id :: String
, checked :: Boolean
, labelClasses :: Array ClassName
}
-> (Unit -> Maybe a)
-> Array (HH.HTML i a)
-> HH.HTML i a
formCheckGroup { id, checked, labelClasses } onChange children =
HH.div
[ P.classes [C.formCheck] ]
[ HH.input
([ P.type_ P.InputRadio
, P.name "recurType"
, P.classes [C.formCheckInput]
, P.id_ id
, E.onClick \_ -> onChange unit
] <> (if checked then [P.checked true] else []))
, HH.label
[ P.classes ([C.formCheckLabel ] <> labelClasses)
, P.for id]
children
]
fieldError :: forall i a. CState -> Field -> Array (HH.HTML i a)
fieldError st field =
if any (_ == field) st.fieldErrors
then case field of
PidField -> err "No project id found; please report an error"
NameField -> err "The name field is required"
DescField -> err "The description field is required"
MessageField -> err "The message field is required"
MonthlyRecurrenceField -> err "You must enter a valid number of months."
WeeklyRecurrenceField -> err "You must enter a valid number of weeks."
AmountField -> err "You must enter a valid amount of ZEC"
GracePeriodField -> err "You must enter a valid number of hours."
RequestExpiryField -> err "You must enter a valid number of hours."
else []
where
err str =
[ HH.div_
[ HH.span
[ P.classes (ClassName <$> [ "badge", "badge-danger-soft" ]) ] [ HH.text str ] ]
]
-- we use a query to initialize, since this is a modal that doesn't actually get unloaded.
handleQuery :: forall slots a. Query a -> H.HalogenM CState Action slots Output m (Maybe a)
handleQuery = case _ of
OpenModal pid a -> do
H.modify_ (\_ -> initialState { projectId = Just pid })
lift $ system.toggleModal modalId ModalFFI.ShowModal
pure (Just a)
handleAction :: forall slots. Action -> H.HalogenM CState Action slots Output m Unit
handleAction = case _ of
SetName name ->
H.modify_ (_ { name = Just name })
SetDesc desc ->
H.modify_ (_ { description = Just desc })
SetMessage msg ->
H.modify_ (_ { message = Just msg })
SetRecurrenceType rtype -> do
curRecurType <- H.gets _.recurrenceType
curDuration <- H.gets _.recurrenceValue
let rdur = case curRecurType of
RTMonthly | rtype == RTMonthly -> curDuration
RTWeekly | rtype == RTWeekly -> curDuration
_ -> Nothing
H.modify_ (_ { recurrenceType = rtype, recurrenceValue = rdur })
SetRecurrenceMonths dur ->
case Int.fromString dur of
(Just n) -> H.modify_ (_ { recurrenceType = RTMonthly, recurrenceValue = Just n })
(Nothing) -> pure unit
SetRecurrenceWeeks dur ->
case Int.fromString dur of
(Just n) -> H.modify_ (_ { recurrenceType = RTWeekly, recurrenceValue = Just n })
(Nothing) -> pure unit
SetBillingAmount amt -> do
curAmount <- H.gets (_.amount)
case Fixed.fromString amt of
(Just (_ :: Fixed.Fixed ZPrec)) ->
H.modify_ (_ { amount = Just amt })
(Nothing) ->
H.modify_ (_ { amount = curAmount })
SetGracePeriod dur ->
case Number.fromString dur of
(Just n) -> H.modify_ (_ { gracePeriod = Just (Days n) })
(Nothing) -> pure unit
SetRequestExpiry dur ->
case Number.fromString dur of
(Just n) -> H.modify_ (_ { requestExpiry = Just (Hours n) })
(Nothing) -> pure unit
Save -> do
pidV <- V <<< note [PidField] <$> H.gets (_.projectId)
nameV <- V <<< note [NameField] <$> H.gets (_.name)
descV <- V <<< note [DescField] <$> H.gets (_.description)
msgV <- V <<< note [MessageField] <$> H.gets (_.message)
rtype <- H.gets (_.recurrenceType)
rvalueV <- case rtype of
RTAnnual -> pure $ V (Right Annually)
RTMonthly -> V <<< maybe (Left [MonthlyRecurrenceField]) (Right <<< Monthly) <$> H.gets (_.recurrenceValue)
RTWeekly -> V <<< maybe (Left [WeeklyRecurrenceField]) (Right <<< Weekly) <$> H.gets (_.recurrenceValue)
RTOneTime -> pure $ V (Right OneTime)
zecStr <- (Fixed.fromString =<< _) <$> H.gets (_.amount)
zatsV <- pure $ V (maybe (Left [AmountField]) (Right <<< toZatoshi <<< ZEC) zecStr)
gperV <- V <<< note [GracePeriodField] <$> H.gets (_.gracePeriod)
expiryV <- V <<< note [RequestExpiryField] <$> H.gets (_.requestExpiry)
let toBillable = { name: _
, description: _
, message: _
, recurrence: _
, amount: _
, gracePeriod: _
, expiryPeriod: _
}
reqV :: V (Array Field) Billable
reqV =
toBillable <$> nameV
<*> descV
<*> msgV
<*> rvalueV
<*> zatsV
<*> gperV
<*> expiryV
case toEither (Tuple <$> pidV <*> reqV) of
Right (Tuple pid billable) -> do
res <- lift $ caps.createBillable pid billable
case res of
Right bid -> do
H.raise (BillableCreated bid)
handleAction Close
Left errs -> do
lift $ system.error (show errs)
Left errors -> do
H.modify_ (_ { fieldErrors = errors })
Close -> do
H.modify_ (const initialState) -- wipe the state for safety
lift $ system.toggleModal modalId ModalFFI.HideModal
apiCapability :: Capability Aff
apiCapability =
{ createBillable: createBillable
}
mockCapability :: Capability Aff
mockCapability =
{ createBillable: \_ _ -> pure $ Left Forbidden }