{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedLists       #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE UndecidableInstances  #-}
-- | Implementation of "Imm.Database" based on a JSON file.
module Imm.Database.JsonFile
  ( JsonFileDatabase
  , mkJsonFileDatabase
  , defaultDatabase
  , mkHandle
  , JsonException(..)
  , module Imm.Database.FeedTable
  ) where

-- {{{ Imports
import           Imm.Database                   hiding (commit, delete, insert,
                                                 purge, update)
import           Imm.Database.FeedTable
import           Imm.Error
import           Imm.Prelude                    hiding (delete, keys)
import           Imm.Pretty

import           Control.Concurrent.MVar.Lifted
import           Data.Aeson
import           Data.ByteString.Lazy           (hPut)
import           Data.ByteString.Streaming      (hGetContents, toLazy_)
import           Data.Map                       (Map)
import qualified Data.Map                       as Map
import qualified Data.Set                       as Set
import           Streaming.With
import           System.Directory
import           System.FilePath
-- }}}

data CacheStatus = Empty | Clean | Dirty
  deriving(Eq, Show)

data JsonFileDatabase t = JsonFileDatabase FilePath (Map (Key t) (Entry t)) CacheStatus

instance Pretty (JsonFileDatabase t) where
  pretty (JsonFileDatabase file _ _) = "JSON database: " <+> pretty file

mkJsonFileDatabase :: (Table t) => FilePath -> JsonFileDatabase t
mkJsonFileDatabase file = JsonFileDatabase file mempty Empty

-- | Default database is stored in @$XDG_CONFIG_HOME\/imm\/feeds.json@
defaultDatabase :: Table t => IO (MVar (JsonFileDatabase t))
defaultDatabase = do
  databaseFile <- getXdgDirectory XdgConfig "imm/feeds.json"
  newMVar $ mkJsonFileDatabase databaseFile


data JsonException = UnableDecode
  deriving(Eq, Show)

instance Exception JsonException where
  displayException _ = "Unable to parse JSON"


mkHandle :: (Table t, FromJSON (Key t), FromJSON (Entry t), ToJSON (Key t), ToJSON (Entry t), MonadBase IO m)
         => MVar (JsonFileDatabase t) -> Handle m t
mkHandle mvar = Handle
  { _describeDatabase = pretty <$> readMVar mvar
  , _fetchList = \keys -> Map.filterWithKey (\uri _ -> member uri $ Set.fromList keys) <$> fetchAll_
  , _fetchAll = fetchAll_
  , _update = \key f -> liftBase $ modifyMVar_ mvar (\a -> update a key f)
  , _insertList = liftBase . modifyMVar_ mvar . insert
  , _deleteList = liftBase . modifyMVar_ mvar . delete
  , _purge = liftBase $ modifyMVar_ mvar purge
  , _commit = liftBase $ modifyMVar_ mvar commit
  }
  where fetchAll_ = liftBase $ modifyMVar mvar $ \database -> do
          a@(JsonFileDatabase _ cache _) <- loadInCache database
          return (a, cache)


-- * Low-level implementation

loadInCache :: (Table t, FromJSON (Key t), FromJSON (Entry t))
            => JsonFileDatabase t -> IO (JsonFileDatabase t)
loadInCache t@(JsonFileDatabase file _ status) = case status of
  Empty -> do
    createDirectoryIfMissing True $ takeDirectory file
    fileContent <- withBinaryFile file ReadWriteMode (toLazy_ . hGetContents)
    cache <- (`failWith` UnableDecode) $ fmap Map.fromList $ decode $ fromEmpty "[]" fileContent
    return $ JsonFileDatabase file cache Clean
  _ -> return t
  where fromEmpty x "" = x
        fromEmpty _ y  = y


insert :: (Table t, FromJSON (Key t), FromJSON (Entry t))
       => [(Key t, Entry t)] -> JsonFileDatabase t -> IO (JsonFileDatabase t)
insert rows t = insertInCache rows <$> loadInCache t

insertInCache :: Table t => [(Key t, Entry t)] -> JsonFileDatabase t -> JsonFileDatabase t
insertInCache rows (JsonFileDatabase file cache _) = JsonFileDatabase file (Map.union cache $ Map.fromList rows) Dirty


update :: (Table t, FromJSON (Key t), FromJSON (Entry t))
       => JsonFileDatabase t -> Key t -> (Entry t -> Entry t) -> IO (JsonFileDatabase t)
update t key f = updateInCache key f <$> loadInCache t

updateInCache :: Table t => Key t -> (Entry t -> Entry t) -> JsonFileDatabase t -> JsonFileDatabase t
updateInCache key f (JsonFileDatabase file cache _) = JsonFileDatabase file newCache Dirty where
  newCache = Map.update (Just . f) key cache

delete :: (Table t, FromJSON (Key t), FromJSON (Entry t))
       => [Key t] -> JsonFileDatabase t -> IO (JsonFileDatabase t)
delete keys t = deleteInCache keys <$> loadInCache t

deleteInCache :: Table t => [Key t] -> JsonFileDatabase t -> JsonFileDatabase t
deleteInCache keys (JsonFileDatabase file cache _) = JsonFileDatabase file newCache Dirty where
  newCache = foldr Map.delete cache keys

purge :: (Table t, FromJSON (Key t), FromJSON (Entry t))
      => JsonFileDatabase t -> IO (JsonFileDatabase t)
purge t = purgeInCache <$> loadInCache t

purgeInCache :: Table t => JsonFileDatabase t -> JsonFileDatabase t
purgeInCache (JsonFileDatabase file _ _) = JsonFileDatabase file mempty Dirty

commit :: (ToJSON (Key t), ToJSON (Entry t))
       => JsonFileDatabase t -> IO (JsonFileDatabase t)
commit t@(JsonFileDatabase file cache status) = case status of
  Dirty -> do
    withFile file WriteMode $ \h -> hPut h $ encode $ Map.toList cache
    return $ JsonFileDatabase file cache Clean
  _ -> return t