{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses, RankNTypes, FunctionalDependencies, DefaultSignatures #-}
module Distribution.Skete.Storage.Interface (
    Version(..), Package, PackageVersion(..)
  , PackageSet
  , MetaMap
  , SketeStorage(..)
  , CommitMessage(..)
  , CommitData(..)
  , parseCommitMessage
  , printCommitMessage
  ) where

import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Data.Foldable
import Data.String
import Data.Time
import Data.Text (Text)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ListTrie.Map.Ord as LT
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Map (Map)
import qualified Data.Map as Map
import Text.Read
import Text.ParserCombinators.ReadP
import Data.Char
import Data.List (intercalate)
import Data.Git (Commit(commitMessage), PathComponent)
import Data.Git.FileTree (FileData)
import Data.Yaml as Y
import System.Filesystem.FileTree

type Package = Text

data Version =
    Version { vParts :: [Int] }
  deriving (Ord, Eq)

instance Show Version where
  show (Version v) = intercalate "." . map show $ v

instance Read Version where
  readsPrec _ = readP_to_S $ (Version . map read) <$> sepBy1 (many1 (satisfy isDigit)) (char '.')

data PackageVersion =
    PV { pvName :: Package, pvVersion :: Version }
  deriving (Ord, Eq)

instance Show PackageVersion where
  show (PV pn pv) = mconcat [T.unpack pn, "-", show pv]

instance Read PackageVersion where
  readsPrec _ = readP_to_S $ do
      pn <- sepBy1 component (char '-')
      void . char $ '-'
      vs <- readS_to_P reads
      return $ PV (T.pack . intercalate "-" $ pn) vs
    where
      -- Matching Cabal
      component = do
        cs <- munch1 isAlphaNum
        if all isDigit cs then mzero else return cs

instance IsString PackageVersion where
    fromString = read

instance ToJSON PackageVersion where
    toJSON = toJSON . show

instance FromJSON PackageVersion where
    parseJSON (Y.String pv) = maybe empty pure (readMaybe . T.unpack $ pv)
    parseJSON _             = empty

type PackageSet = Text
type MetaMap = Map PathComponent ByteString

-- | The hinting of time should possibly be a SketeStorageTemporal class instance set,
-- | or special functions of backends that provide time.
-- | A perfectly reasonable backend might not store time in any way.
-- |
-- | conf describes whatever the particular SketeStorage needs to be run via 'storage'
-- | ref is an opaque handle to a package in the storage system.
class Monad m => SketeStorage conf m ref | m -> ref, m -> conf where
  storage :: MonadIO mp => conf -> m a -> mp a
  add :: ToJSON a => PackageVersion -> a -> FileTree FileData -> m ref
  default add :: (MonadIO m, ToJSON a) => PackageVersion -> a -> FileTree FileData -> m ref
  add pid cd dt = liftIO getCurrentTime >>= \t -> add' pid cd t dt
  -- | The UTCTime is mearly a hint that storage implimentations are free to ignore.
  add' :: ToJSON a => PackageVersion -> a -> UTCTime -> FileTree FileData -> m ref
  add' pv a _ fd = add pv a fd
  lookup :: PackageVersion -> m (Maybe ref)
  versionData :: FromJSON a => ref -> m (Maybe a)
  versionFiles :: ref -> m (FileTree FileData)
  versionFile :: ref -> [PathComponent] -> m (Maybe BSL.ByteString)
  versionFile r fp = (fmap fst . LT.lookup fp) <$> versionFiles r
  labels :: m [PackageSet]
  label :: ref -> MetaMap -> PackageSet -> m ()
  default label :: MonadIO m => ref -> MetaMap -> PackageSet -> m ()
  label pid m l = liftIO getCurrentTime >>= label' pid m l
  -- | The UTCTime is mearly a hint that storage implimentations are free to ignore.
  label' :: ref -> MetaMap -> PackageSet -> UTCTime -> m ()
  label' r mm ps _ = label r mm ps
  labelMulti :: PackageSet -> [(ref, MetaMap)] -> m ()
  labelMulti ps = mapM_ (\(r, m) -> label r m ps)
  labelData :: PackageSet -> PackageVersion -> m (Maybe MetaMap)
  labelDataLookup :: PackageSet -> PackageVersion -> PathComponent -> m (Maybe ByteString)
  labelDataLookup ps pv k = (join . fmap (Map.lookup k)) <$> labelData ps pv
  --labelDataInsert :: PackageSet -> PackageVersion -> FilePath -> ByteString -> m ()
  --labelDataDelete :: PackageSet -> PackageVersion -> FilePath -> m ()
  packageData :: PackageSet -> Package -> m (Maybe MetaMap)
  labelPackage :: PackageSet -> Package -> MetaMap -> m ()
  default labelPackage :: (MonadIO m) => PackageSet -> Package -> MetaMap -> m ()
  labelPackage ps pn mm = liftIO getCurrentTime >>= \t -> labelPackage' ps pn mm t
  labelPackage' :: PackageSet -> Package -> MetaMap -> UTCTime -> m ()
  labelPackage' ps pn mm _ = labelPackage ps pn mm
  packageDataLookup :: PackageSet -> Package -> PathComponent -> m (Maybe ByteString)
  packageDataLookup ps pn k = (join . fmap (Map.lookup k)) <$> packageData ps pn
  list :: PackageSet -> m [PackageVersion]
  {-# MINIMAL storage, (add | add'), lookup, versionFiles, versionData, labels, (label | label'), labelData, packageData, (labelPackage | labelPackage'), list #-}

data CommitMessage = Add PackageVersion
                   | Label PackageVersion PackageSet
                   | Annotate Package PackageSet
                     deriving (Eq, Ord, Show)

instance ToJSON CommitMessage where
    toJSON (Add pv)       = object ["add" .= pv]
    toJSON (Label pv lbl) = object ["label" .= object ["package" .= pv, "to" .= lbl]]
    toJSON (Annotate pn lbl) = object ["Annotate" .= object ["package" .= pn, "for" .= lbl]]

instance FromJSON CommitMessage where
    parseJSON (Object o) = Add <$> o .: "add"
                           <|> do Object o' <- o .: "label"
                                  Label <$> o' .: "package" <*> o' .: "to"
    parseJSON _          = empty

data CommitData = CommitData {
      sketeData :: CommitMessage
    , clientData :: Maybe Y.Value
} deriving (Eq, Show)

instance ToJSON CommitData where
    toJSON (CommitData m Nothing)  = toJSON [m]
    toJSON (CommitData m (Just a)) = toJSON [toJSON m, a]

instance FromJSON CommitData where
    parseJSON (Array vs) = case toList vs of
                             []        -> empty
                             [cm]      -> CommitData <$> parseJSON cm <*> pure Nothing
                             (cm:cd:_) -> CommitData <$> parseJSON cm <*> (pure $ Just cd)
    parseJSON _          = empty

parseCommitMessage :: Commit -> Maybe CommitData
parseCommitMessage = decode . BSL.toStrict . commitMessage

printCommitMessage :: CommitData -> Text
printCommitMessage = TE.decodeUtf8 . encode

parseText :: Text -> Maybe PackageVersion
parseText = readMaybe . T.unpack