{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | This module exports a 'I.Store' that stores 'I.Backup' data as files in the
-- filesystem, as well as a 'I.Registry' backed by a file in the filesystem and
-- related tools.
--
-- Please import as:
--
-- @
-- import qualified "Moto.File"
-- @
module Moto.File
 ( -- * Registry
   registryConf
 , withRegistry

 , -- * Store
   store
 ) where

import Control.Applicative (empty)
import qualified Control.Exception.Safe as Ex
import qualified Control.Monad.Trans.State.Strict as S
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans (lift)
import qualified Data.Aeson as Ae
import qualified Data.Attoparsec.ByteString.Char8 as A8
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as BB
import qualified Data.Char as Char
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import GHC.IO.Handle as IO (LockMode(ExclusiveLock), hLock)
import qualified Pipes as P
import qualified Pipes.Attoparsec as Pa
import qualified Pipes.ByteString as Pb
import qualified System.Directory as Dir
import System.FilePath ((</>))
import qualified System.IO as IO
import qualified System.IO.Error as IO

import qualified Moto.Internal as I
import qualified Moto.Internal.Cli as IC
import qualified Moto.Registry as R

--------------------------------------------------------------------------------

-- | Command-line configuration for a 'I.Registry' stored as a file in the
-- filesystem using 'withRegistry'.
registryConf :: IC.RegistryConf
registryConf = IC.RegistryConf
  { IC.registryConf_help =
      "File where registry file is stored. E.g., \
      \file:///var/db/migrations"
  , IC.registryConf_parse = \case
      'f':'i':'l':'e':':':'/':'/':xs -> case xs of
          ""  -> Left "Invalid file path"
          "/" -> Left "Invaild file path"
          _   -> Right xs
      _ -> Left "Invalid file path"
  , IC.registryConf_with = withRegistry
  }

-- | Obtain a 'I.Registry' backed by an append-only file storage, using @moto@'s
-- own file format.
withRegistry
  :: (MonadIO m, Ex.MonadMask m)
  => IO.FilePath
  -- ^ File where to store the registry logs.
  --
  -- An exclusive lock will be set on the this file (see 'IO.hLock'), which will
  -- stay open until this function returns. This is to prevent other programs to
  -- interact with this file while this program is running.
  -> (I.Registry -> m a)
  -> m a
withRegistry fp =
  withRegistryCustom renderLogLine parseLogLine fp

-- | Obtain a 'I.Registry' backed by an append-only file storage as described by
-- 'R.newAppendOnlyRegistry'.
withRegistryCustom
  :: (MonadIO m, Ex.MonadMask m)
  => (I.Log -> BB.Builder)
  -- ^ Render a single 'I.Log'. Be sure to add a trailing newline or similar if
  -- necessary, in order to separate one 'I.Log' entry from the next.
  -> A8.Parser I.Log
  -- ^ Parse a single 'I.Log'. Be sure to consume and discard any trailing
  -- newline or similar separating one rendered 'I.Log' entry from the next.
  -> IO.FilePath
  -- ^ File where to store the registry logs.
  --
  -- An exclusive lock will be set on the this file (see 'IO.hLock'), which will
  -- stay open until this function returns. This is to prevent other programs to
  -- interact with this file while this program is running.
  -> (I.Registry -> m a)
  -> m a
withRegistryCustom render parser fp k = do
  Ex.bracket
    (liftIO $ do
       h <- IO.openBinaryFile fp IO.ReadWriteMode
       IO.hLock h IO.ExclusiveLock
       pure h)
    (liftIO . IO.hClose)
    (\h -> k =<< liftIO (do
       state0 <- do
          ea <- flip S.runStateT I.emptyState $ P.runEffect $ do
             P.for (Pa.parsed parser (Pb.fromHandle h)) $ \l -> do
                s0 <- lift S.get
                lift (either Ex.throwM S.put (I.updateState s0 l))
          case ea of
             (Left (e,_), _) -> Ex.throwM (I.Err_MalformedLog (show e))
             (Right _, x) -> pure x
       R.newAppendOnlyRegistry state0 $ \log' -> do
          BB.hPutBuilder h (render log')
          IO.hFlush h))

--------------------------------------------------------------------------------

-- Renders a 'I.Log' as a line of text with a trailing new line.
--
-- Use 'parseLogLine' to undo this rendering.
renderLogLine :: I.Log -> BB.Builder
renderLogLine l = Ae.fromEncoding (Ae.toEncoding (LogV1 l)) <> "\n"

-- Parses a 'I.Log' from a line of text rendered by 'renderLogLine'.
--
-- Any leading or trailing newlines are consumed and skipped.
parseLogLine :: A8.Parser I.Log
parseLogLine = do
  _ <- A8.skipWhile (== '\n')
  s <- A8.takeWhile (/= '\n')
  _ <- A8.skipWhile (== '\n')
  case Ae.decodeStrict s of
     Just (LogV1 l) -> pure l
     Nothing -> fail "Malformed Log"

-- | Wrapper around 'I.Log' used for serialization purposes, so that we don't
-- expose a 'Ae.ToJSON' instance for 'I.Log'.
newtype LogV1 = LogV1 I.Log

instance Ae.ToJSON LogV1 where
  toJSON (LogV1 l) = case l of
    I.Log_Commit t -> Ae.toJSON $ Ae.object
      [ "action" Ae..= ("commit" :: T.Text)
      , "timestamp" Ae..= t ]
    I.Log_Abort t -> Ae.toJSON $ Ae.object
      [ "action" Ae..= ("abort" :: T.Text)
      , "timestamp" Ae..= t ]
    I.Log_Prepare t (I.MigId m) d -> Ae.toJSON $ Ae.object
      [ "action" Ae..= ("prepare" :: T.Text)
      , "timestamp" Ae..= t
      , "migration" Ae..= m
      , "direction" Ae..= (I.direction "backwards" "forwards" d :: T.Text) ]

instance Ae.FromJSON LogV1 where
  parseJSON = Ae.withObject "Log" $ \o -> do
    a :: T.Text <- o Ae..: "action"
    fmap LogV1 $ case a of
       "commit" -> I.Log_Commit
          <$> (o Ae..: "timestamp")
       "abort" -> I.Log_Abort
          <$> (o Ae..: "timestamp")
       "prepare" -> I.Log_Prepare
          <$> (o Ae..: "timestamp")
          <*> fmap I.MigId (o Ae..: "migration")
          <*> (o Ae..: "direction" >>= \case
                  "backwards" -> pure I.Backwards
                  "forwards" -> pure I.Forwards
                  (_ :: T.Text) -> empty)
       _ -> empty

--------------------------------------------------------------------------------

-- | A 'Store' that keeps data stored as files (one per 'MigId') in a filesystem
-- directory.
--
-- For maximum memory consumption efficiency, the data is written and read in a
-- streaming fasion using a 'P.Producer'.
store
  :: FilePath -- ^ Path to a directory where the files are or will be stored.
  -> I.Store (P.Producer B.ByteString IO ())
store fp_dir = I.Store
    { I.store_save = \_ mId x -> do
        Dir.createDirectoryIfMissing True fp_dir
        Ex.bracket
          (IO.openBinaryFile (fp mId) IO.WriteMode)
          IO.hClose
          (\h -> do
             IO.hSetFileSize h 0
             IO.hSetBuffering h (IO.BlockBuffering Nothing)
             P.runEffect (x P.>-> Pb.toHandle h))
    , I.store_load = \_ mId k -> Ex.bracket
        (IO.openBinaryFile (fp mId) IO.ReadMode)
        IO.hClose
        (k . Pb.fromHandle)
    , I.store_delete = \_ mId -> Ex.catch
        (Dir.removeFile (fp mId))
        (\case e | IO.isDoesNotExistError e -> pure ()
                 | otherwise -> Ex.throwM e)
    }
  where
    fp :: I.MigId -> FilePath
    fp = \mId -> fp_dir </> TL.unpack (TL.decodeUtf8 (I.migId_sha1Hex mId)) <>
                            "_" <> escapeFileName (T.unpack (I.unMigId mId))
    escapeFileName :: String -> FilePath
    escapeFileName = map (\case c | Char.isAscii c && Char.isAlphaNum c -> c
                                  | otherwise -> '_')

{- TODO save this to a README file
    readme :: BB.Builder
    readme = "This directory contains backups made by Moto.File.store.\n\
             \\n\
             \  https://hackage.haskell.org/package/moto/docs/Moto-File.html#v:store\n\n\
             \\n\
             \To backup these backups, it is sufficient to copy the contents\n\
             \of this directory, preserving the file names."
-}