content: {-# LANGUAGE BlockArguments #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  
  module RON.Store.FS (
      module RON.Store,
      Handle,
      Store,
      debugDump,
      fetchUpdates,
      newHandle,
      newHandleWithReplica,
      runStore,
  ) where
  
  import RON.Prelude
  
  import Control.Concurrent (MVar, newMVar, withMVar)
  import Control.Concurrent.STM (
      TChan,
      atomically,
      dupTChan,
      newBroadcastTChanIO,
      writeTChan,
   )
  import Control.Exception (throwIO)
  import Data.Bits (shiftL)
  import Data.ByteString qualified as BS
  import Data.ByteString.Lazy qualified as BSL
  import Data.ByteString.Lazy.Char8 qualified as BSLC
  import Data.Foldable (find)
  import Data.IORef (newIORef)
  import Network.Info (MAC (MAC), getNetworkInterfaces, mac)
  import System.Directory (
      createDirectoryIfMissing,
      doesDirectoryExist,
      listDirectory,
      makeAbsolute,
   )
  import System.FileLock (SharedExclusive (Exclusive), tryLockFile)
  import System.FilePath ((</>))
  import System.Random.TF (newTFGen)
  import System.Random.TF.Instances (random)
  
  import RON.Data.VersionVector (VV, (·≼))
  import RON.Epoch (EpochClock, getCurrentEpochTime, runEpochClock)
  import RON.Error (
      Error (..),
      MonadE,
      errorContext,
      liftEitherString,
      throwErrorText,
      tryIO,
   )
  import RON.Event (
      OriginVariety (ApplicationSpecific),
      Replica,
      ReplicaClock,
      getEventUuid,
      mkReplica,
   )
  import RON.Store (MonadStore (..))
  import RON.Text.Parse (parseOpenFrame)
  import RON.Text.Serialize.Experimental (serializeOpenFrame)
  import RON.Types (Op (..), UUID)
  import RON.Types.Experimental (Patch (..))
  import RON.UUID qualified as UUID
  import RON.Util.Word (Word60, leastSignificant60)
  
  -- | Store handle (uses the “Handle pattern”).
  data Handle = Handle
      { clock :: IORef Word60
      , dataDir :: FilePath
      , onObjectChanged :: TChan UUID
      {- ^ A channel of changes in the database.
      This is a broadcast channel, so you MUST NOT read from it directly,
      call 'fetchUpdates' to read from derived channel instead.
      -}
      , opLock :: MVar ()
      , replica :: Replica
      }
  
  newtype Store a = Store (ExceptT Error (ReaderT Handle EpochClock) a)
      deriving
          (Applicative, Functor, Monad, MonadError Error, MonadIO, ReplicaClock)
  
  instance MonadStore Store where
      listObjects =
          errorContext "Store.listObjects" do
              Handle{dataDir} <- Store ask
              objectDirs <-
                  tryIO do
                      exists <- doesDirectoryExist dataDir
                      if exists then listDirectoryDirs dataDir else pure []
              traverse uuidFromFileName objectDirs
  
      appendPatch = appendPatchFS
  
      loadWholeObjectLog = loadWholeObjectLogFS
  
  askObjectLogsDir :: (MonadReader Handle m) => UUID -> m FilePath
  askObjectLogsDir objectId = do
      Handle{dataDir} <- ask
      pure $ dataDir </> uuidToFileName objectId </> "log"
  
  getObjectPatches :: UUID -> Store [FilePath]
  getObjectPatches objectId = do
      objectLogsDir <- Store $ askObjectLogsDir objectId
      objectExists <- tryIO $ doesDirectoryExist objectLogsDir
      if objectExists then tryIO $ listDirectory objectLogsDir else pure []
  
  loadWholeObjectLogFS :: UUID -> VV -> Store [Op]
  loadWholeObjectLogFS objectId version = do
      objectLogsDir <- Store $ askObjectLogsDir objectId
      patchNames <- getObjectPatches objectId
      fold . catMaybes <$> for patchNames \patchName -> do
          patchTimestamp <- uuidFromFileName patchName
          if patchTimestamp ·≼ version then
              pure Nothing
          else do
              let patchFile = objectLogsDir </> patchName
              patchContent <- tryIO $ BS.readFile patchFile
              patch <-
                  liftEitherString $ parseOpenFrame $ BSL.fromStrict patchContent
              pure $ Just patch
  
  appendPatchFS :: Patch -> Store ()
  appendPatchFS Patch{object, log} = do
      Handle{dataDir, onObjectChanged} <- Store ask
      let objectLogsDir = dataDir </> uuidToFileName object </> "log"
      tryIO $ createDirectoryIfMissing True objectLogsDir
      patchVersion <- getEventUuid
      let patchFile = objectLogsDir </> uuidToFileName patchVersion
      tryIO $ BSL.writeFile patchFile $ serializeOpenFrame $ toList log
      tryIO $ atomically $ writeTChan onObjectChanged object
  
  -- | Run a 'Store' action
  runStore :: Handle -> Store a -> IO a
  runStore h@Handle{replica, clock, opLock} (Store action) = do
      res <-
          withMVar opLock \_ ->
              runEpochClock replica clock $ (`runReaderT` h) $ runExceptT action
      either throwIO pure res
  
  {- | Create new storage handle.
  Uses MAC address for replica id or generates a random one.
  -}
  newHandle :: FilePath -> IO (Maybe Handle)
  newHandle dataDir = do
      macAddress <- getMacAddress
      replicaId <-
          case macAddress of
              Just macAddress' -> pure macAddress'
              Nothing -> fst . random <$> newTFGen
      newHandleWithReplica dataDir $ leastSignificant60 replicaId
  
  newHandleWithReplica :: FilePath -> Word60 -> IO (Maybe Handle)
  newHandleWithReplica dataDir' replicaId = do
      dataDir <- makeAbsolute dataDir'
      let appLockFile = dataDir </> "applock"
      mLock <- tryLockFile appLockFile Exclusive
      case mLock of
          Nothing -> pure Nothing
          Just _ -> do
              time <- getCurrentEpochTime
              clock <- newIORef time
              onObjectChanged <- newBroadcastTChanIO
              opLock <- newMVar ()
              let replica = mkReplica ApplicationSpecific replicaId
              pure $ Just Handle{..}
  
  getMacAddress :: IO (Maybe Word64)
  getMacAddress =
      do
          macAddress <- getMac
          pure $ decodeMac <$> macAddress
    where
      getMac = find (/= minBound) . map mac <$> getNetworkInterfaces
      decodeMac (MAC b5 b4 b3 b2 b1 b0) =
          (fromIntegral b5 `shiftL` 40)
              + (fromIntegral b4 `shiftL` 32)
              + (fromIntegral b3 `shiftL` 24)
              + (fromIntegral b2 `shiftL` 16)
              + (fromIntegral b1 `shiftL` 8)
              + fromIntegral b0
  
  uuidFromFileName :: (MonadE m) => FilePath -> m UUID
  uuidFromFileName name =
      maybe
          ( throwErrorText $
              "UUID.decodeBase32: file name "
                  <> show name
                  <> " is not a valid UUID"
          )
          pure
          (UUID.decodeBase32 name)
  
  uuidToFileName :: UUID -> FilePath
  uuidToFileName = UUID.encodeBase32
  
  debugDump :: FilePath -> IO ()
  debugDump dataDir = do
      objectDirs <- do
          exists <- doesDirectoryExist dataDir
          if exists then listDirectory dataDir else pure []
      for_ (sort objectDirs) \objectDir -> do
          isDir <- doesDirectoryExist $ dataDir </> objectDir
          when isDir do
              let logsDir = dataDir </> objectDir </> "log"
              logs <- listDirectory logsDir
              for_ (sort logs) \logName -> do
                  let logPath = logsDir </> logName
                  BSL.putStr =<< BSL.readFile logPath
              BSLC.putStrLn ""
  
  fetchUpdates :: Handle -> IO (TChan UUID)
  fetchUpdates Handle{onObjectChanged} = atomically $ dupTChan onObjectChanged
  
  listDirectoryDirs :: FilePath -> IO [FilePath]
  listDirectoryDirs dir =
      listDirectory dir >>= filterM (\name -> doesDirectoryExist (dir </> name))
  