summaryrefslogtreecommitdiff
path: root/lib/Badges.hs
blob: b78f08dc124d74379bb68ca6a47c86c845a815c4 (plain)
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 ])