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
|
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- | module defining Badge types and utility functions
module Badges where
import Data.Aeson (Options (fieldLabelModifier, sumEncoding),
SumEncoding (UntaggedValue), ToJSON (toJSON),
defaultOptions, genericToJSON, (.=))
import qualified Data.Aeson as A
import Data.Char (toLower)
import Data.Text (Text)
import GHC.Generics (Generic)
import Text.Regex.TDFA ((=~))
data BadgeArea =
BadgePoint
{ areaX :: Double
, areaY :: Double
}
| BadgeRect
{ areaX :: Double
, areaY :: Double
, areaWidth :: Double
, areaHeight :: Double
, areaIsEllipse :: Bool
}
deriving (Ord, Eq, Generic, Show)
newtype BadgeToken = BadgeToken Text
deriving (Eq, Ord, Show)
instance ToJSON BadgeArea where
toJSON = genericToJSON defaultOptions
{ fieldLabelModifier = drop 4 . map toLower
, sumEncoding = UntaggedValue }
instance ToJSON BadgeToken where
toJSON (BadgeToken text) = toJSON text
parseToken :: Text -> Maybe BadgeToken
parseToken text = if text =~ ("^[a-zA-Z0-9]{50}$" :: Text) -- TODO: add character limit
then Just (BadgeToken text)
else Nothing
data Badge = Badge BadgeToken BadgeArea
deriving (Ord, Eq, Generic, Show)
badgeJsonArray :: A.KeyValue a => Badge -> [a]
badgeJsonArray (Badge token area) =
[ "token" .= token ] <> areaObject
where areaObject = case area of
BadgePoint x y -> [ "x" .= x
, "y" .= y
, "type" .= A.String "point"
]
BadgeRect {..} -> [ "x" .= areaX
, "y" .= areaY
, "width" .= areaWidth
, "height" .= areaHeight
, "type" .= if areaIsEllipse
then A.String "ellipse"
else A.String "rectangle"
]
badgeJson :: FilePath -> Badge -> A.Value
badgeJson mappath badge = A.object (badgeJsonArray badge <> [ "map" .= mappath ])
|
