1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
|
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NamedFieldPuns #-}
--------------------------------------------------------------------------------
module Types where
--------------------------------------------------------------------------------
import Data.Aeson
import Data.Function ((&))
import Data.Text
import Data.Typeable
import Database.Persist.TH
import Database.SQLite.Simple
import Database.SQLite.Simple.Ok
import Database.SQLite.Simple.FromField
import Database.SQLite.Simple.ToField
import GHC.Generics
import qualified Data.ByteString as BS
--------------------------------------------------------------------------------
-- TODO(wpcarro): Properly handle NULL for columns like profilePicture.
forNewtype :: (Typeable b) => (Text -> b) -> FieldParser b
forNewtype wrapper field =
case fieldData field of
(SQLText x) -> Ok (wrapper x)
_ -> returnError ConversionFailed field ""
newtype Username = Username Text
deriving (Eq, Show, Generic)
instance ToJSON Username
instance FromJSON Username
instance ToField Username where
toField (Username x) = SQLText x
instance FromField Username where
fromField = forNewtype Username
newtype Password = Password Text
deriving (Eq, Show, Generic)
instance ToJSON Password
instance FromJSON Password
instance ToField Password where
toField (Password x) = SQLText x
instance FromField Password where
fromField = forNewtype Password
newtype Email = Email Text
deriving (Eq, Show, Generic)
instance ToJSON Email
instance FromJSON Email
instance ToField Email where
toField (Email x) = SQLText x
instance FromField Email where
fromField = forNewtype Email
data Role = RegularUser | Manager | Admin
deriving (Eq, Show, Generic)
instance ToJSON Role
instance FromJSON Role
instance ToField Role where
toField RegularUser = SQLText "user"
toField Manager = SQLText "manager"
toField Admin = SQLText "admin"
instance FromField Role where
fromField field =
case fieldData field of
(SQLText "user") -> Ok RegularUser
(SQLText "manager") -> Ok Manager
(SQLText "admin") -> Ok Admin
_ -> returnError ConversionFailed field ""
-- TODO(wpcarro): Prefer Data.ByteString instead of Text
newtype ProfilePicture = ProfilePicture Text
deriving (Eq, Show, Generic)
instance ToJSON ProfilePicture
instance FromJSON ProfilePicture
instance ToField ProfilePicture where
toField (ProfilePicture x) = SQLText x
instance FromField ProfilePicture where
fromField = forNewtype ProfilePicture
data Account = Account
{ accountUsername :: Username
, accountPassword :: Password
, accountEmail :: Email
, accountRole :: Role
, accountProfilePicture :: ProfilePicture
} deriving (Eq, Show, Generic)
-- TODO(wpcarro): Prefer username to accountUsername for JSON
instance ToJSON Account
instance FromJSON Account
-- | Return a tuple with all of the fields for an Account record to use for SQL.
accountFields :: Account -> (Username, Password, Email, Role, ProfilePicture)
accountFields (Account { accountUsername
, accountPassword
, accountEmail
, accountRole
, accountProfilePicture
})
= ( accountUsername
, accountPassword
, accountEmail
, accountRole
, accountProfilePicture
)
instance FromRow Account where
fromRow = Account <$> field
<*> field
<*> field
<*> field
<*> field
data Session = Session
{ username :: Username
, password :: Password
, role :: Role
} deriving (Eq, Show)
instance ToJSON Session where
toJSON (Session username password role) =
object [ "username" .= username
, "password" .= password
, "role" .= role
]
newtype Comment = Comment Text
deriving (Eq, Show, Generic)
instance ToJSON Comment
instance FromJSON Comment
instance ToField Comment where
toField (Comment x) = SQLText x
instance FromField Comment where
fromField = forNewtype Comment
-- TODO(wpcarro): Replace this with a different type.
newtype Date = Date Text
deriving (Eq, Show, Generic)
instance ToJSON Date
instance FromJSON Date
instance ToField Date where
toField (Date x) = SQLText x
instance FromField Date where
fromField = forNewtype Date
newtype Destination = Destination Text
deriving (Eq, Show, Generic)
-- TODO(wpcarro): Prefer username to tripUsername for JSON
instance ToJSON Destination
instance FromJSON Destination
instance ToField Destination where
toField (Destination x) = SQLText x
instance FromField Destination where
fromField = forNewtype Destination
data Trip = Trip
{ tripUsername :: Username
, tripDestination :: Destination
, tripStartDate :: Date
, tripEndDate :: Date
, tripComment :: Comment
} deriving (Eq, Show, Generic)
-- | Return the tuple representation of a Trip record for SQL.
tripFields :: Trip -> (Username, Destination, Date, Date, Comment)
tripFields (Trip{ tripUsername
, tripDestination
, tripStartDate
, tripEndDate
, tripComment
})
= ( tripUsername
, tripDestination
, tripStartDate
, tripEndDate
, tripComment
)
instance ToJSON Trip
instance FromJSON Trip
|
