module Handler.Utils.Files
  ( sourceFile, sourceFile'
  , sourceFiles, sourceFiles'
  , SourceFilesException(..)
  , sourceFileDB, sourceFileMinio
  , acceptFile
  , respondFileConditional
  ) where

import Import.NoFoundation
import Foundation.Type
import Utils.Metrics

import qualified Data.Conduit.Combinators as C
import qualified Data.Conduit.List as C (unfoldM)

import Handler.Utils.Minio
import qualified Network.Minio as Minio

import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E

import System.FilePath (normalise, makeValid)
import Data.List (dropWhileEnd)


data SourceFilesException
  = SourceFilesMismatchedHashes
  | SourceFilesContentUnavailable
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
  deriving anyclass (Exception)


sourceFileDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX)
             => FileContentReference -> ConduitT () ByteString (SqlPersistT m) ()
sourceFileDB fileReference = do
  dbChunksize <- getsYesod $ view _appFileUploadDBChunksize
  let retrieveChunk chunkHash = \case
        Nothing -> return Nothing
        Just start -> do
          chunk <- E.selectMaybe . E.from $ \fileContentChunk -> do
            E.where_ $ fileContentChunk E.^. FileContentChunkId E.==. E.val chunkHash
            return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val dbChunksize)
          case chunk of
            Nothing -> throwM SourceFilesContentUnavailable
            Just (E.Value c) -> do
              observeSourcedChunk StorageDB $ olength c
              return . Just . (c, ) $ if
                | olength c >= dbChunksize -> Just $ start + dbChunksize
                | otherwise                -> Nothing
      chunkHashes = E.selectSource . E.from $ \fileContentEntry -> do
        E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileReference
        E.orderBy [ E.asc $ fileContentEntry E.^. FileContentEntryIx ]
        return $ fileContentEntry E.^. FileContentEntryChunkHash
  chunkHashes .| C.map E.unValue .| awaitForever (\chunkHash -> C.unfoldM (retrieveChunk chunkHash) $ Just (1 :: Int))


sourceFileMinio :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m)
                => FileContentReference -> ConduitT () ByteString m ()
sourceFileMinio fileReference = do
  chunkVar <- newEmptyTMVarIO
  minioAsync <- lift . allocateLinkedAsync $
    maybeT (throwM SourceFilesContentUnavailable) $ do
      let uploadName = minioFileReference # fileReference
      uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket
      hoistMaybe <=< runAppMinio . runMaybeT $ do
        objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket uploadName Minio.defaultGetObjectOptions
        lift . runConduit $ Minio.gorObjectStream objRes .| C.mapM_ (atomically . putTMVar chunkVar)
  let go = do
        mChunk <- atomically $ Right <$> takeTMVar chunkVar
                           <|> Left  <$> waitCatchSTM minioAsync
        case mChunk of
          Right chunk -> do
            observeSourcedChunk StorageMinio $ olength chunk
            yield chunk
            go
          Left (Right ()) -> return ()
          Left (Left exc) -> throwM exc
   in go


sourceFiles :: (Monad m, YesodPersistBackend UniWorX ~ SqlBackend) => ConduitT FileReference DBFile m ()
sourceFiles = C.map sourceFile

sourceFile :: YesodPersistBackend UniWorX ~ SqlBackend
           => FileReference -> DBFile
sourceFile FileReference{..} = File
  { fileTitle = fileReferenceTitle
  , fileModified = fileReferenceModified
  , fileContent = toFileContent <$> fileReferenceContent
  }
  where
    toFileContent fileReference
      | fileReference == $$(liftTyped $ FileContentReference $$(emptyHash))
      = return ()
    toFileContent fileReference = do
      inDB <- lift . E.selectExists . E.from $ \fileContentEntry -> E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileReference
      bool sourceFileMinio sourceFileDB inDB fileReference

sourceFiles' :: forall file m. (HasFileReference file, Monad m, YesodPersistBackend UniWorX ~ SqlBackend) => ConduitT file DBFile m ()
sourceFiles' = C.map sourceFile'

sourceFile' :: forall file. (HasFileReference file, YesodPersistBackend UniWorX ~ SqlBackend) => file -> DBFile
sourceFile' = sourceFile . view (_FileReference . _1)

respondFileConditional :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, YesodPersistBackend UniWorX ~ SqlBackend, YesodPersistRunner UniWorX)
                       => Maybe UTCTime -> MimeType
                       -> FileReference
                       -> SqlPersistT m (HandlerFor UniWorX a)
respondFileConditional representationLastModified cType FileReference{..} = do
  if
    | Just fileContent <- fileReferenceContent
    , fileContent == $$(liftTyped $ FileContentReference $$(emptyHash))
      -> return . respondSourceConditional @ByteRangesSpecifier condInfo cType . Left $ (return () :: ConduitT () ByteString _ ())
    | Just fileContent <- fileReferenceContent -> do
        dbManifest <- fmap fromNullable . E.select . E.from $ \(fileContentEntry `E.LeftOuterJoin` fileContentChunk) -> do
          E.on $ E.just (fileContentEntry E.^. FileContentEntryChunkHash) E.==. fileContentChunk E.?. FileContentChunkId
          E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileContent
          E.orderBy [E.asc $ fileContentEntry E.^. FileContentEntryIx ]
          return ( fileContentChunk E.?. FileContentChunkHash
                 , E.maybe E.nothing (E.just . E.length_) $ fileContentChunk E.?. FileContentChunkContent
                 )
        case dbManifest of
          Nothing -> do
            uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket
            let uploadName = minioFileReference # fileContent
            statRes <- maybeT (throwM SourceFilesContentUnavailable) . (hoistMaybe <=< runAppMinio) . runMaybeT $ do
              catchIfMaybeT minioIsDoesNotExist $ Minio.statObject uploadBucket uploadName Minio.defaultGetObjectOptions
            let iLength = fromIntegral $ Minio.oiSize statRes
            respondSourceConditional condInfo cType . Right $ \byteRange ->
              let byteRange' = case byteRange of
                    ByteRangeSpecification f Nothing -> ByteRangeFrom (fromIntegral $ min (pred iLength) f)
                    ByteRangeSpecification f (Just t) -> ByteRangeFromTo (fromIntegral $ min iLength f) (fromIntegral $ min (pred iLength) t)
                    ByteRangeSuffixSpecification s -> ByteRangeSuffix (fromIntegral $ min iLength s)
                  respRange = case byteRange of
                    ByteRangeSpecification f Nothing -> ByteRangeResponseSpecification (min (pred iLength) f) (pred iLength)
                    ByteRangeSpecification f (Just t) -> ByteRangeResponseSpecification (min (pred iLength) f) (min (pred iLength) t)
                    ByteRangeSuffixSpecification s -> ByteRangeResponseSpecification (iLength - min (pred iLength) s) (pred iLength)
               in ( do
                      chunkVar <- newEmptyTMVarIO
                      minioAsync <- lift . allocateLinkedAsync $
                        maybeT (throwM SourceFilesContentUnavailable) . (hoistMaybe <=< runAppMinio) . runMaybeT $ do
                          objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket uploadName Minio.defaultGetObjectOptions{ Minio.gooRange = Just byteRange' }
                          lift . runConduit $ Minio.gorObjectStream objRes .| C.mapM_ (atomically . putTMVar chunkVar)
                      let go = do
                            mChunk <- atomically $ Right <$> takeTMVar chunkVar
                                               <|> Left  <$> waitCatchSTM minioAsync
                            case mChunk of
                              Right chunk -> do
                                observeSourcedChunk StorageMinio $ olength chunk
                                yield chunk
                                go
                              Left (Right ()) -> return ()
                              Left (Left exc) -> throwM exc
                       in go
                  , ByteContentRangeSpecification (Just respRange) (Just iLength)
                  )
          Just (toNullable -> dbManifest')
            | Just dbManifest'' <- forM dbManifest' $ \(E.Value chunkHash, E.Value chunkLength) -> (,) <$> chunkHash <*> chunkLength
              -> do
                let iLength = sumOf (folded . _2) dbManifest''
                respondSourceDBConditional condInfo cType . Right $ \byteRange ->
                  let (byteFrom, byteTo) = case byteRange of
                        ByteRangeSpecification f Nothing -> (min (pred iLength) f, pred iLength)
                        ByteRangeSpecification f (Just t) -> (min (pred iLength) f, min (pred iLength) t)
                        ByteRangeSuffixSpecification s -> (iLength - min (pred iLength) s, pred iLength)
                      relevantChunks = view _2 $ foldl' go (0, []) dbManifest''
                        where go :: (Natural, [(FileContentChunkReference, Natural, Natural)])
                                 -> (FileContentChunkReference, Natural)
                                 -> (Natural, [(FileContentChunkReference, Natural, Natural)])
                              go (lengthBefore, acc) (cChunk, cLength)
                                = ( lengthBefore + cLength
                                  , if
                                      | byteFrom < lengthBefore + cLength, byteTo >= lengthBefore
                                        -> let cChunk' = ( cChunk
                                                         , bool 0 (byteFrom - lengthBefore) $ byteFrom >= lengthBefore
                                                         , bool cLength (cLength - pred (lengthBefore + cLength - byteTo)) $ byteTo < lengthBefore + cLength
                                                         )
                                            in acc ++ pure cChunk'
                                      | otherwise
                                        -> acc
                                  )
                   in ( do
                          dbChunksize <- getsYesod $ views _appFileUploadDBChunksize fromIntegral
                          forM_ relevantChunks $ \(chunkHash, offset, cLength)
                            -> let retrieveChunk = \case
                                     Just (start, cLength') | cLength' > 0 -> do
                                       chunk <- E.selectMaybe . E.from $ \fileContentChunk -> do
                                         E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash
                                         return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val $ min cLength' dbChunksize)
                                       case chunk of
                                         Nothing -> throwM SourceFilesContentUnavailable
                                         Just (E.Value c) -> do
                                           observeSourcedChunk StorageDB $ olength c
                                           return . Just . (c, ) $ if
                                             | fromIntegral (olength c) >= min cLength' dbChunksize
                                               -> Just (start + dbChunksize, cLength' - fromIntegral (olength c))
                                             | otherwise
                                               -> Nothing
                                     _other -> return Nothing
                                in C.unfoldM retrieveChunk . Just $ (succ offset, cLength)
                      , ByteContentRangeSpecification (Just $ ByteRangeResponseSpecification byteFrom byteTo) (Just iLength)
                      )
            | otherwise -> throwM SourceFilesContentUnavailable
            
    | otherwise
      -> return $ sendResponseStatus noContent204 ()
  where
    condInfo = RepresentationConditionalInformation
      { representationETag = review etagFileReference <$> fileReferenceContent
      , representationLastModified
      , representationExists = True
      , requestedActionAlreadySucceeded = Nothing
      }


  
acceptFile :: (MonadResource m, MonadResource m') => FileInfo -> m (File m')
acceptFile fInfo = do
  let fileTitle = "." <//> unpack (fileName fInfo)
                & normalise
                & makeValid
                & dropWhile isPathSeparator
                & dropWhileEnd isPathSeparator
                & normalise
                & makeValid
      fileContent = Just $ fileSource fInfo
  fileModified <- liftIO getCurrentTime
  return File{..}