{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}

module Settlr.Storage
  ( Group(..)
  , Member(..)
  , Money(..)
  , Currency(..)
  , GroupMetadata(..)
  , getMetadata
  , createGroup
  , deleteGroup
  , Expense(..)
  , expAmount
  , expSaldo
  , getExpenses
  , getSaldo
  , addExpense
  ) where

import Data.Text (Text)
import qualified Data.Text as T
import Data.Map (Map)
import qualified Data.Map as M
import Data.UUID (UUID)
import Data.Maybe (fromMaybe)
import Data.Time (UTCTime)
import Control.Monad.Catch (MonadThrow, throwM)
import Text.Read (readMaybe)
import Control.Exception (Exception, try, IOException)
import Data.List (find, stripPrefix)
import Data.Maybe (mapMaybe)
import Settlr.Scripts (ScriptM)
import Control.Monad.Reader (asks, MonadIO (liftIO))
import Settlr.Config (Config(..))
import Network.CGI (formDecode, formEncode)
import Data.UUID.V4 (nextRandom)
import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)

-- Identifier of a group.
newtype Group = Group UUID
  deriving (Eq, Ord, Show)

-- Identifier of a group member.
newtype Member = Member Text
  deriving (Eq, Ord, Show)

-- An amount of money in a particular currency (usually, the smallest unit for the currency).
newtype Money = Money Int
  deriving (Eq, Ord, Num, Show)

data Currency = EUR | USD
  deriving (Eq, Show, Read)

data GroupMetadata = GroupMetadata
  { grpName      :: !Text
  , grpCreatedAt :: !UTCTime
  , grpCurrency  :: !Currency
  , grpMembers   :: ![Member]
  }
  deriving (Show)

getMetadata :: Group -> ScriptM (Maybe GroupMetadata)
getMetadata grp = do basePath <- groupPath grp
                     readEncoded (basePath ++ "/metadata")

createGroup :: GroupMetadata -> ScriptM Group
createGroup meta = do grp      <- Group <$> liftIO nextRandom
                      basePath <- groupPath grp
                      liftIO $ createDirectoryIfMissing True basePath
                      writeEncoded (basePath ++ "/metadata") meta
                      pure grp

deleteGroup :: Group -> ScriptM ()
deleteGroup grp = do basePath <- groupPath grp
                     liftIO $ removeDirectoryRecursive basePath

data Expense = Expense
  { expDescription :: !Text
  , expCreatedAt   :: !UTCTime
  , expCreditor    :: !Member
  , expDebtors     :: !(Map Member Money)
  }
  deriving (Show)

expAmount :: Expense -> Money
expAmount expense = M.foldr (+) (Money 0) (expDebtors expense)

expSaldo :: Member -> Expense -> Money
expSaldo mem expense = positiveAmount - negativeAmount
  where positiveAmount = if expCreditor expense == mem
                           then expAmount expense
                           else Money 0
        negativeAmount = fromMaybe (Money 0) (M.lookup mem (expDebtors expense))

getExpenses :: Group -> ScriptM [Expense]
getExpenses = undefined

getSaldo :: Member -> Group -> ScriptM Money
getSaldo mem grp = sum . fmap (expSaldo mem) <$> getExpenses grp

addExpense :: Expense -> Group -> ScriptM ()
addExpense = undefined

groupPath :: Group -> ScriptM FilePath
groupPath (Group grp) = do dataPath <- asks cfgDataPath
                           let dataPath' = fromMaybe dataPath (T.stripSuffix "/" dataPath)
                           pure $ T.unpack (dataPath' <> "/groups/" <> T.pack (show grp))

readEncoded :: Codable c => FilePath -> ScriptM (Maybe c)
readEncoded path = liftIO (try (readFile path) :: IO (Either IOException String)) >>= \case
                     Left _        -> pure Nothing
                     Right content -> Just <$> decode (formDecode content)

writeEncoded :: Codable c => FilePath -> c -> ScriptM ()
writeEncoded path content = liftIO $ writeFile path (formEncode (encode content))

class Codable a where
  encode :: a -> [(String, String)]
  decode :: MonadThrow m => [(String, String)] -> m a

instance Codable GroupMetadata where
  encode grp = [ ("name"     , T.unpack (grpName grp))
               , ("createdAt", show (grpCreatedAt grp))
               , ("currency" , show (grpCurrency grp))
               ] ++
               fmap (\(Member x) -> ("member", T.unpack x)) (grpMembers grp)
  decode rec = do name       <- T.pack    <$> lookupThrow "name"      rec
                  createdAt  <- readThrow =<< lookupThrow "createdAt" rec
                  currency   <- readThrow =<< lookupThrow "currency"  rec
                  let members = (Member . T.pack <$> lookupMany "member" rec)
                  pure $ GroupMetadata { grpName      = name
                                       , grpCreatedAt = createdAt
                                       , grpCurrency  = currency
                                       , grpMembers   = members
                                       }

instance Codable Expense where
  encode expense = [ ("description", T.unpack (expDescription expense))
                   , ("createdAt"  , show (expCreatedAt expense))
                   , ("creditor"   , (\(Member x) -> T.unpack x) (expCreditor expense))
                   ] ++
                   fmap (\(Member x, Money y) -> ("debtor" ++ T.unpack x, show y)) (M.toList (expDebtors expense))
  decode rec = do description <- T.pack          <$> lookupThrow "description" rec
                  createdAt   <- readThrow       =<< lookupThrow "createdAt"   rec
                  creditor    <- Member . T.pack <$> lookupThrow "creditor"    rec
                  let debtorItems = mapMaybe (\(x, y) -> (, y) <$> stripPrefix "debtor" x) rec
                  debtors <- mapM (\(x, y) -> (Member (T.pack x), ) . Money <$> readThrow y) debtorItems
                  pure $ Expense { expDescription = description
                                 , expCreatedAt   = createdAt
                                 , expCreditor    = creditor
                                 , expDebtors     = M.fromList debtors
                                 }

data CodingException
  = CodingInvalidValue !String
  | CodingMissingKey !String

instance Show CodingException where
  show (CodingInvalidValue val) = "Decoding failed: Invalid value \"" ++ val ++ "\""
  show (CodingMissingKey key)   = "Decoding failed: Invalid key \"" ++ key ++ "\""

instance Exception CodingException

readThrow :: MonadThrow m => Read a => String -> m a
readThrow str = case readMaybe str of
                  Just x  -> pure x
                  Nothing -> throwM (CodingInvalidValue str)

lookupThrow :: MonadThrow m => String -> [(String, String)] -> m String
lookupThrow key rec = case find (\(x, _) -> x == key) rec of
                        Just (_, y) -> pure y
                        Nothing     -> throwM (CodingMissingKey key)

lookupMany :: String -> [(String, String)] -> [String]
lookupMany key rec = snd <$> filter (\(x, _) -> x == key) rec