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"