{-# 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
 , jsonStore
 ) where

import Control.Applicative (empty)
import qualified Control.Exception.Safe as Ex
import Control.Monad (when)
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 Data.Maybe (isJust)
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Di.Df1 as Di
import GHC.IO.Handle as IO (LockMode(ExclusiveLock), hLock)
import qualified Pipes as P
import qualified Pipes.Aeson as PAe
import qualified Pipes.Aeson.Unchecked as PAeu
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_with = withRegistry
  , IC.registryConf_help =
      "File where registry file is stored. E.g., /var/db/migrations"
  , IC.registryConf_parse = \case
      fp@('/':_) -> pure fp
      _ -> Left "File path must be absolute."
  }

-- | Obtain a 'I.Registry' backed by an append-only file storage, using @moto@'s
-- own file format.
withRegistry
  :: (MonadIO m, Ex.MonadMask m)
  => Di.Df1
  -> 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 di0 fp k =
  withRegistryCustom renderLogLine parseLogLine di0 fp k

-- | 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.
  -> Di.Df1
  -> 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 di0 fp k = do
  let di1 = Di.attr "file" fp di0
  Ex.bracket
    (liftIO $ do
       Di.debug_ di1 "Opening registry file..."
       h <- IO.openBinaryFile fp IO.ReadWriteMode
       Di.debug_ di1 "Acquiring exclusive file lock..."
       IO.hLock h IO.ExclusiveLock
       pure h)
    (\h -> liftIO $ do
       Di.debug_ di1 "Closing registry file..."
       IO.hClose h)
    (\h -> k =<< liftIO (do
       Di.debug_ di1 "Loading state from registry..."
       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."
-}

-- | Like 'store', but serializes data in a JSON format.
--
-- WARNING: This holds all of @x@ in memory, so avoid using 'jsonStore' if your
-- data is too large.
jsonStore :: (Ae.FromJSON x, Ae.ToJSON x) => FilePath -> I.Store x
jsonStore fp =
  let s0 = store fp
  in I.Store
     { I.store_delete = I.store_delete s0
     , I.store_save = \di mId x -> do
         I.store_save s0 di mId (PAeu.encode x)
     , I.store_load = \di mId k -> do
         I.store_load s0 di mId $ \p0 -> do
           yea <- S.evalStateT PAeu.decode p0
           case yea of
             Nothing -> Ex.throwM Err_JsonStoreLoad_NoInput
             Just (Left e) -> Ex.throwM (Err_JsonStoreLoad_Decoding e)
             Just (Right x) -> k x
     }

-- | And error from 'jsonStore''s 'I.store_load'.
data Err_JsonStoreLoad
  = Err_JsonStoreLoad_NoInput
  | Err_JsonStoreLoad_Decoding PAe.DecodingError
  deriving (Show)
instance Ex.Exception Err_JsonStoreLoad