summaryrefslogtreecommitdiff
path: root/Model.hs
blob: 6d0fd048ba0a3107b2b2952516fd2900a893839f (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
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
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PatternGuards #-}

module Model where

import ClassyPrelude.Yesod
import Database.Persist.Quasi

import Control.Monad.Writer

import           Data.Text   (Text)
import qualified Data.Text as Text

import           Data.Map   ((!))
import qualified Data.Map as Map

import qualified Data.HashMap.Lazy as HashMap

import Data.Aeson
import Data.Aeson.Types (Parser, Value(..))

import Model.Types

-- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities
-- at:
-- http://www.yesodweb.com/book/persistent/
share [mkPersist sqlSettings, mkMigrate "migrateAll"]
    $(persistFileWith lowerCaseSettings "config/models")

class HasType a where
  fkType :: a -> Key Kind
  
getType :: ( BaseBackend backend ~ SqlBackend
           , MonadIO m
           , PersistStoreRead backend
           , HasType a
           ) => a -> ReaderT backend m Kind
getType = getJust . fkType

instance HasType Item where
  fkType = itemFkType

instance HasType Reference where
  fkType = referenceFkType

instance HasType a => HasType (Entity a) where
  fkType = fkType . entityVal
    

withType :: ( BaseBackend backend ~ SqlBackend
            , MonadIO m
            , PersistStoreRead backend
            , HasType a
            ) => a -> ReaderT backend m (WithType a)
withType val = (val `WithType`) . kindType <$> getType val

withTypes :: ( BaseBackend backend ~ SqlBackend
             , MonadIO m
             , PersistStoreRead backend
             , PersistQueryRead backend
             , HasType a
             , Functor f
             ) => f a -> ReaderT backend m (f (WithType a))
withTypes vals = do
  typeMap <- Map.fromList . map (\(Entity kindKey kind) -> (kindKey, kind)) <$> selectList [] []
  let
    lookupType x = (x `WithType`) . kindType $ typeMap ! fkType x
  return $ lookupType <$> vals

instance Ord Item where
  x `compare` y = mconcat cmprs
    where
      cmprs = [ comparing (isNever . itemExpires) x y
              , comparing itemOpened x y
              , comparing itemExpires x y
              , (comparing not `on` itemRunningLow) x y
              , comparing itemKind x y
              , comparing itemBought x y
              ]

instance ToJSON Item where
  toJSON Item{..} = object $
    [ "kind" .= itemKind
    , "bought" .= itemBought
    , "expires" .= itemExpires
    , "opened" .= itemOpened
    , "running-low" .= itemRunningLow
    ]

instance FromJSON Item where
  parseJSON = withObject "Item" $ \obj -> do
    itemKind <- obj .: "kind"
    let
      itemNormKind = normalizeKind itemKind
    itemBought <- maybe DateUnknown DateKnown <$> obj .:? "bought"
    itemExpires <- maybe DateNever DateKnown <$> obj .:? "expires"
    itemOpened <- obj .: "opened"
    itemRunningLow <- fromMaybe False <$> obj .:? "running-low"
    return Item{..}
  
instance ToJSON (Entity Item) where
  toJSON = entityIdToJSON

instance FromJSON (Entity Item) where
  parseJSON = entityIdFromJSON

instance ToJSON Reference where
  toJSON Reference{..} = String referenceKind

instance FromJSON Reference where
  parseJSON = withText "Reference" $ \referenceKind -> do
    let
      referenceNormKind = normalizeKind referenceKind
    return Reference{..}

instance ToJSON (Entity Reference) where
  toJSON = keyValueEntityToJSON

instance FromJSON (Entity Reference) where
  parseJSON = keyValueEntityFromJSON

normalizeKind :: Text -> Text
normalizeKind = Text.strip . Text.toCaseFold

data ItemDiff = DiffKind Text
              | DiffType Text
              | DiffBought ItemDate
              | DiffExpires ItemDate
              | DiffOpened ItemDate
              | DiffRunningLow Bool

newtype ItemDiffs = ItemDiffs [ItemDiff]

instance FromJSON ItemDiffs where
  parseJSON = withObject "ItemDiff" $ \obj -> fmap ItemDiffs . execWriterT $ do
    tell =<< maybe [] (pure . DiffKind) <$> lift (obj .:? "kind")
    tell =<< maybe [] (pure . DiffType) <$> lift (obj .:? "type")
    tell =<< maybe [] (pure . DiffBought) <$> lift (obj .:! "bought")
    tell =<< maybe [] (pure . DiffExpires) <$> lift (obj .:! "expires")
    tell =<< maybe [] (pure . DiffOpened) <$> lift (obj .:! "opened")
    tell =<< maybe [] (pure . DiffRunningLow) <$> lift (obj .:? "running-low")

toUpdate :: ItemDiffs -> ([Update Item], [Update Kind])
toUpdate (ItemDiffs ds) = mconcat $ do
  x <- ds
  return $ case x of
    DiffKind t    -> (, []) [ ItemKind =. t
                            , ItemNormKind =. normalizeKind t
                            ]
    DiffType t    -> ([], ) [ KindType =. t ]
    DiffBought d  -> (, []) [ ItemBought =. d ]
    DiffExpires d -> (, []) [ ItemExpires =. d ]
    DiffOpened d  -> (, []) [ ItemOpened =. d ]
    DiffRunningLow b -> (, []) [ ItemRunningLow =. b ]

data WithType a = WithType { typedVal :: a, valType :: Text }
  deriving (Eq, Ord, Show, Functor)

typeToJSON :: ToJSON a
           => Text -- ^ Key for value, if needed
           -> WithType a -> Value
typeToJSON valKey (record `WithType` t) = Object $ HashMap.insert "type" (toJSON t) o
  where
    o
      | Object o' <- toJSON record = o'
      | otherwise = HashMap.singleton valKey $ toJSON record

typeFromJSON :: FromJSON a
             => Maybe Text -- ^ Key for value, if needed
             -> Value -> Parser (WithType a)
typeFromJSON valKey = withObject "value with type" $ \obj -> do
  t <- obj .: "type"
  value <- case valKey of
    Just key -> parseJSON =<< obj .: key
    Nothing  -> parseJSON $ Object obj
  return $ value `WithType` t

instance ToJSON (WithType Item) where
  toJSON = typeToJSON $ error "Item is not serializing correctly"

instance ToJSON (WithType (Entity Item)) where
  toJSON = typeToJSON $ error "Entity Item is not serializing correctly"

instance ToJSON (WithType Reference) where
  toJSON = typeToJSON "kind"

instance ToJSON (WithType (Entity Reference)) where
  toJSON ((Entity eId ref) `WithType` t) = object
    [ "id" .= eId
    , "type" .= t
    , "kind" .= referenceKind ref
    ]

instance FromJSON (WithType Item) where
  parseJSON = typeFromJSON Nothing

instance FromJSON (WithType Reference) where
  parseJSON = typeFromJSON $ Just "kind"