1 {-# LANGUAGE TemplateHaskell, DataKinds, TypeFamilies, OverloadedStrings #-}
    2 {-# OPTIONS_GHC -fno-warn-orphans #-}
    3 module Databrary.Model.Notification.Notice
    4   ( Delivery(..)
    5   , fromMaybeDelivery
    6   , periodicDelivery
    7   , Notice(..)
    8   , noticeId
    9   , getNotice
   10   , getNotice'
   11   ) where
   12 
   13 import qualified Data.Aeson.Types as JSON
   14 import Control.Arrow (left)
   15 import qualified Data.ByteString.Char8 as BSC
   16 import Data.Int (Int16)
   17 import Data.Maybe (fromMaybe)
   18 import qualified Data.Text as T
   19 import Database.PostgreSQL.Typed.Types (PGParameter(..), PGColumn(..))
   20 import Database.PostgreSQL.Typed.Dynamic (PGRep)
   21 import qualified Data.Typeable.Internal
   22 import qualified GHC.Arr
   23 import qualified Database.PostgreSQL.Typed.Types
   24 import qualified Database.PostgreSQL.Typed.Enum
   25 import qualified Data.ByteString
   26 
   27 import Databrary.HTTP.Form (FormDatum(..))
   28 import Databrary.HTTP.Form.Deform
   29 import Databrary.Model.Kind
   30 import Databrary.Model.Id
   31 import Databrary.Model.Enum
   32 import Databrary.Model.Periodic
   33 import Databrary.Model.Notification.Boot
   34 
   35 -- makeDBEnum "notice_delivery" "Delivery"
   36 -- TODO: db coherence
   37 data Delivery
   38   = DeliveryNone |
   39     DeliverySite |
   40     DeliveryWeekly |
   41     DeliveryDaily |
   42     DeliveryAsync
   43   deriving (Eq,
   44             Ord,
   45             Enum,
   46             GHC.Arr.Ix,
   47             Bounded,
   48             Data.Typeable.Internal.Typeable)
   49 instance Show Delivery where
   50   show DeliveryNone = "none"
   51   show DeliverySite = "site"
   52   show DeliveryWeekly = "weekly"
   53   show DeliveryDaily = "daily"
   54   show DeliveryAsync = "async"
   55 instance Database.PostgreSQL.Typed.Types.PGType "notice_delivery"
   56 instance PGParameter "notice_delivery" Delivery where
   57   pgEncode _ DeliveryNone = Data.ByteString.pack [110, 111, 110, 101]
   58   pgEncode _ DeliverySite = Data.ByteString.pack [115, 105, 116, 101]
   59   pgEncode _ DeliveryWeekly
   60     = Data.ByteString.pack [119, 101, 101, 107, 108, 121]
   61   pgEncode _ DeliveryDaily
   62     = Data.ByteString.pack [100, 97, 105, 108, 121]
   63   pgEncode _ DeliveryAsync
   64     = Data.ByteString.pack [97, 115, 121, 110, 99]
   65 instance PGColumn "notice_delivery" Delivery where
   66   pgDecode _ x_a42l0
   67     = case Data.ByteString.unpack x_a42l0 of
   68         [110, 111, 110, 101] -> DeliveryNone
   69         [115, 105, 116, 101] -> DeliverySite
   70         [119, 101, 101, 107, 108, 121] -> DeliveryWeekly
   71         [100, 97, 105, 108, 121] -> DeliveryDaily
   72         [97, 115, 121, 110, 99] -> DeliveryAsync
   73         _ -> error ("pgDecode notice_delivery: " ++ (BSC.unpack x_a42l0))
   74 instance PGRep "notice_delivery" Delivery
   75 instance Database.PostgreSQL.Typed.Enum.PGEnum Delivery
   76 instance Kinded Delivery where
   77   kindOf _ = "notice_delivery"
   78 instance DBEnum Delivery
   79 instance JSON.ToJSON Delivery where
   80   toJSON = (JSON.toJSON . fromEnum)
   81 instance JSON.FromJSON Delivery where
   82   parseJSON = parseJSONEnum
   83 instance Deform f_a42l1 Delivery where
   84   deform = enumForm
   85 
   86 fromMaybeDelivery :: Maybe Delivery -> Delivery
   87 fromMaybeDelivery (Just d) = d
   88 fromMaybeDelivery Nothing = DeliveryNone
   89 
   90 periodicDelivery :: Maybe Period -> Delivery
   91 periodicDelivery (Just PeriodDaily) = DeliveryDaily
   92 periodicDelivery (Just PeriodWeekly) = DeliveryWeekly
   93 periodicDelivery Nothing = DeliveryAsync
   94 
   95 makeNotice
   96 
   97 noticeFromId' :: Int16 -> Notice
   98 noticeFromId' = fromMaybe (error "noticeFromId'") . noticeFromId
   99 
  100 instance PGParameter "smallint" Notice where
  101   pgEncode t = pgEncode t . noticeToId
  102   pgEncodeValue e t = pgEncodeValue e t . noticeId
  103   pgLiteral t = pgLiteral t . noticeToId
  104 instance PGColumn "smallint" Notice where
  105   pgDecode t = noticeFromId' . pgDecode t
  106   pgDecodeValue e t = noticeFromId' . pgDecodeValue e t
  107 instance PGRep "smallint" Notice
  108 
  109 type instance IdType Notice = Int16
  110 
  111 noticeId :: Notice -> Id Notice
  112 noticeId = Id . noticeToId
  113 
  114 getNotice :: Id Notice -> Maybe Notice
  115 getNotice (Id i) = noticeFromId i
  116 
  117 getNotice' :: Id Notice -> Notice
  118 getNotice' = fromMaybe (error "getNotice'") . getNotice
  119 
  120 instance Kinded Notice where
  121   kindOf _ = "notice"
  122 instance JSON.ToJSON Notice where
  123   toJSON = JSON.toJSON . noticeToId
  124 instance JSON.FromJSON Notice where
  125   parseJSON (JSON.String t) | Just e <- noticeFromName (T.unpack t) = return e
  126   parseJSON (JSON.Number x) = maybe (fail "notice out of range") return $ noticeFromId (round x)
  127   parseJSON _ = fail "Invalid notice"
  128 instance Deform f Notice where
  129   deform = deformParse minBound fv where
  130     fv (FormDatumBS b) = maybe (fail "Invalid notice") return $ noticeFromName $ BSC.unpack b
  131     fv (FormDatumJSON j) = left T.pack $ JSON.parseEither JSON.parseJSON j
  132     fv _ = fail "Invalid notice"