Record.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UnicodeSyntax #-}

module Database.Record (
  FeedStatus (..),
  markFeedAsUnprocessed,
  touchFeed,
  FeedItemStatus (..),
  markItemAsProcessed,
  markItemAsUnprocessed,
  FeedRecord (..),
  mkFeedRecord,
  FeedItemRecord (..),
  prettyItemRecord,
  mkFeedItemRecord,
  Inserted,
  NotInserted,
)
where

import Control.Monad.Time
import Data.Aeson
import qualified Data.Text as Text (null)
import Data.Time
import Imm.Feed
import Imm.Pretty
import URI.ByteString

-- | Stateful information on a feed
data FeedStatus = FeedStatus
  { _feedTags ∷ Set Text
  , _feedLastUpdate ∷ Maybe UTCTime
  }
  deriving (Eq, Generic, Ord, Read, Show, Typeable)

feedStatusOptions ∷ Options
feedStatusOptions =
  defaultOptions
    { fieldLabelModifier = camelTo2 '_' . drop (length @[] "_feed")
    , omitNothingFields = True
    }

instance ToJSON FeedStatus where
  toJSON = genericToJSON feedStatusOptions
  toEncoding = genericToEncoding feedStatusOptions

instance FromJSON FeedStatus where
  parseJSON = genericParseJSON feedStatusOptions

instance Pretty FeedStatus where
  pretty FeedStatus{..} = tags <++> "Last update:" <+> lastUpdate
   where
    tags = sep $ map ((<>) "#" . pretty) $ toList _feedTags
    lastUpdate = maybe "never" prettyTime _feedLastUpdate

markFeedAsUnprocessed ∷ FeedStatus → FeedStatus
markFeedAsUnprocessed status =
  status
    { _feedLastUpdate = Nothing
    }

touchFeed ∷ FeedStatus → IO FeedStatus
touchFeed status = do
  utcTime ← currentTime
  return $ status{_feedLastUpdate = Just utcTime}

-- | Stateful information on a feed item
newtype FeedItemStatus = FeedItemStatus
  { _isProcessed ∷ Bool
  }
  deriving (Eq, Generic, Ord, Read, Show, Typeable)

instance Pretty FeedItemStatus where
  pretty FeedItemStatus{..} = pretty _isProcessed

feedItemStatusOptions ∷ Options
feedItemStatusOptions =
  defaultOptions
    { fieldLabelModifier = camelTo2 '_'
    , omitNothingFields = True
    }

instance ToJSON FeedItemStatus where
  toJSON = genericToJSON feedItemStatusOptions
  toEncoding = genericToEncoding feedItemStatusOptions

instance FromJSON FeedItemStatus where
  parseJSON = genericParseJSON feedItemStatusOptions

markItemAsProcessed ∷ FeedItemStatus → FeedItemStatus
markItemAsProcessed status = status{_isProcessed = True}

markItemAsUnprocessed ∷ FeedItemStatus → FeedItemStatus
markItemAsUnprocessed status = status{_isProcessed = False}

-- | Consistent record of information for a single feed
data FeedRecord status = FeedRecord
  { _feedKey ∷ StatusUID status
  , _feedLocation ∷ FeedLocation
  , _feedDefinition ∷ FeedDefinition
  , _feedStatus ∷ FeedStatus
  }

deriving instance Eq (StatusUID s) ⇒ Eq (FeedRecord s)

deriving instance Ord (StatusUID s) ⇒ Ord (FeedRecord s)

deriving instance Show (StatusUID s) ⇒ Show (FeedRecord s)

instance Pretty (PrettyKey (FeedRecord Inserted)) where
  pretty (PrettyKey record) = pretty $ _feedKey record

instance Pretty (PrettyKey (FeedRecord NotInserted)) where
  pretty (PrettyKey record) = pretty $ _feedLocation record

instance Pretty (PrettyName (FeedRecord s)) where
  pretty (PrettyName record) = if Text.null title then location else definition
   where
    title = record & _feedDefinition & _feedTitle
    definition = prettyName $ _feedDefinition record
    location = feedUri & uriAuthority <&> authorityHost <&> hostBS & fromMaybe "unknown" & decodeUtf8 & pretty @Text
    FeedLocation feedUri _alternateTitle = _feedLocation record

mkFeedRecord ∷ FeedLocation → FeedDefinition → FeedStatus → FeedRecord NotInserted
mkFeedRecord = FeedRecord ()

-- | Consistent record of information for a single feed item
data FeedItemRecord status = FeedItemRecord
  { _itemKey ∷ StatusUID status
  , _itemFeedKey ∷ UID
  , _itemDefinition ∷ FeedItem
  , _itemStatus ∷ FeedItemStatus
  }

deriving instance Eq (StatusUID s) ⇒ Eq (FeedItemRecord s)

deriving instance Ord (StatusUID s) ⇒ Ord (FeedItemRecord s)

deriving instance Show (StatusUID s) ⇒ Show (FeedItemRecord s)

instance Pretty (PrettyKey (FeedItemRecord Inserted)) where
  pretty (PrettyKey record) = pretty $ _itemKey record

instance Pretty (PrettyName (FeedItemRecord a)) where
  pretty (PrettyName record) = pretty $ _itemTitle $ _itemDefinition record

prettyItemRecord ∷ Pretty (StatusUID s) ⇒ FeedItemRecord s → Doc AnsiStyle
prettyItemRecord FeedItemRecord{..} =
  pretty _itemKey
    <+> magenta (pretty _itemFeedKey)
      <++> pretty _itemDefinition
      <++> pretty _itemStatus

mkFeedItemRecord ∷ UID → FeedItem → FeedItemStatus → FeedItemRecord NotInserted
mkFeedItemRecord = FeedItemRecord ()

data Inserted

data NotInserted

type family StatusUID s where
  StatusUID Inserted = UID
  StatusUID NotInserted = ()