module Handler.Utils.Download
  ( sendThisFile
  , sendFileReference
  , serveOneFile
  , serveSomeFiles
  , serveSomeFiles'
  , serveZipArchive
  , serveZipArchive'
  ) where

import Import.NoFoundation
import Foundation.Type
import Foundation.Authorization

import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HashMap

import qualified Data.Conduit.Combinators as C

import Handler.Utils.Zip
import Handler.Utils.ContentDisposition
import Handler.Utils.Files

import qualified Network.Wai as W


data DownloadTokenRestriction
  = DownloadRestrictSingle { downloadRestrictReference :: FileContentReference }
  | DownloadRestrictMultiple
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 2
  , fieldLabelModifier = camelToPathPiece' 2
  } ''DownloadTokenRestriction

withFileDownloadTokenMaybe' :: forall url m.
                               ( HasRoute UniWorX url
                               , MonadHandler m, HandlerSite m ~ UniWorX
                               , MonadCrypto m
                               , MonadCryptoKey m ~ CryptoIDKey
                               , YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId
                               )
                            => Maybe (ConduitT () (Either FileReference DBFile) m ())
                            -> url
                            -> m (SomeRoute UniWorX)
withFileDownloadTokenMaybe' mSource route = maybeT (return $ SomeRoute route) $ do
  let rApproot = authoritiveApproot $ urlRoute route
  case rApproot of
    ApprootDefault -> mzero
    _other -> return ()
  guardM . getsYesod $ \app -> views _appRoot (is _Just . ($ rApproot)) app
                            && views _appRoot ($ ApprootDefault) app /= views _appRoot ($ rApproot) app

  uid <- MaybeT maybeAuthId
  now <- liftIO getCurrentTime
  expireOffset <- getsYesod $ view _appDownloadTokenExpire
  restr <- case mSource of
    Just source -> do
      results <- lift . runConduit $ source .| C.take 2 .| C.foldMap (pure . either Just (const Nothing))
      return $ case results of
        [Just FileReference{ fileReferenceContent = Just ref }] -> DownloadRestrictSingle ref
        _other -> DownloadRestrictMultiple
    Nothing -> return DownloadRestrictMultiple
  bearer <- lift $ bearerRestrict (urlRoute route) restr <$> bearerToken
    (HashSet.singleton $ Right uid)
    (Just uid)
    (HashMap.singleton BearerTokenRouteAccess . HashSet.singleton $ urlRoute route)
    Nothing
    (Just . Just $ addUTCTime expireOffset now)
    Nothing
  encodedBearer <- lift $ encodeBearer bearer

  lift . setDownload $ SomeRoute @UniWorX route
    & over (urlRouteParams $ Proxy @UniWorX) (((toPathPiece GetBearer, toPathPiece encodedBearer) :) . filter (views _1 (maybe False (/= GetBearer) . fromPathPiece)))

  where
    setDownload :: SomeRoute UniWorX -> m (SomeRoute UniWorX)
    setDownload route' = do
      wantsDownload <- downloadFiles
      defWantsDownload <- getsYesod $ views _appUserDefaults userDefaultDownloadFiles
      let
        addDownload params
          | anyOf (folded . _1) (== toPathPiece GetDownload) params = params
          | otherwise = (toPathPiece GetDownload, toPathPiece wantsDownload) : params
      return $ route'
        & over (urlRouteParams $ Proxy @UniWorX) (bool id addDownload $ wantsDownload /= defWantsDownload)

-- withFileDownloadToken' :: forall file url m.
--                           ( HasFileReference file
--                           , HasRoute UniWorX url
--                           , MonadHandler m, HandlerSite m ~ UniWorX
--                           , MonadCrypto m
--                           , MonadCryptoKey m ~ CryptoIDKey
--                           , YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId
--                           )
--                        => ConduitT () (Either file DBFile) m ()
--                        -> url
--                        -> m (SomeRoute UniWorX)
-- withFileDownloadToken' = withFileDownloadTokenMaybe' . Just . (.| C.map (first . view $ _FileReference . _1))


-- withFileDownloadToken :: forall file url m.
--                          ( HasFileReference file
--                          , HasRoute UniWorX url
--                          , MonadHandler m, HandlerSite m ~ UniWorX
--                          , MonadCrypto m
--                          , MonadCryptoKey m ~ CryptoIDKey
--                          , BearerAuthSite UniWorX
--                          )
--                       => ConduitT () file m ()
--                       -> url
--                       -> m (SomeRoute UniWorX)
-- withFileDownloadToken = withFileDownloadToken' . (.| C.map Left)

ensureApprootUserGeneratedMaybe'
  :: forall m.
     ( MonadHandler m, HandlerSite m ~ UniWorX
     , MonadCrypto m
     , MonadCryptoKey m ~ CryptoIDKey
     , YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId
     )
  => Maybe (ConduitT () (Either FileReference DBFile) m ())
  -> m ()
ensureApprootUserGeneratedMaybe' source = maybeT_ $ do
  route <- (,) <$> MaybeT getCurrentRoute <*> fmap reqGetParams getRequest
  $logDebugS "ensureApproot" $ tshow route
  rApproot <- hoistMaybe <=< lift . runMaybeT $ do
    reqHost <- MaybeT $ W.requestHeaderHost <$> waiRequest
    let rApproot = authoritiveApproot $ urlRoute route 
    guard $ rApproot == ApprootUserGenerated
    approotHost <- MaybeT . getsYesod $ approotScopeHost rApproot
    guard $ approotHost /= reqHost
    return rApproot
  $logDebugS "ensureApproot" $ tshow rApproot
  route' <- lift $ withFileDownloadTokenMaybe' source route
  url <- approotRender rApproot route'
  $logDebugS "ensureApprootUserGenerated" url
  redirect url
  

-- | Simply send a `File`-Value
sendThisFile :: ( YesodAuthPersist UniWorX
                , AuthEntity UniWorX ~ User
                , AuthId UniWorX ~ UserId
                , YesodPersistRunner UniWorX
                , MonadCrypto (HandlerFor UniWorX), MonadCryptoKey (HandlerFor UniWorX) ~ CryptoIDKey
                ) => DBFile -> HandlerFor UniWorX TypedContent
sendThisFile File{..} = do
  ensureApprootUserGeneratedMaybe' Nothing
  if
    | Just fileContent' <- fileContent -> do
        setCSPSandbox
        setContentDisposition' . Just $ takeFileName fileTitle
        let cType = simpleContentType (mimeLookup $ pack fileTitle) <> "; charset=utf-8"
        respondSourceDB cType $
          fileContent' .| C.map toFlushBuilder
    | otherwise -> sendResponseStatus noContent204 ()

sendFileReference :: forall file a.
                     ( HasFileReference file
                     , BearerAuthSite UniWorX
                     , YesodPersistBackend UniWorX ~ SqlBackend
                     , YesodPersistRunner UniWorX
                     )
                  => file -> HandlerFor UniWorX a
sendFileReference (view (_FileReference . _1) -> fRef@FileReference{..}) = do
  ensureApprootUserGeneratedMaybe' . Just . yield $ Left fRef
  whenIsJust fileReferenceContent $ \fRef' -> do
    dlRestr <- maybeCurrentBearerRestrictions
    case dlRestr of
      Just (DownloadRestrictSingle restrRef) | restrRef == fRef' -> return ()
      _other -> setCSPSandbox
    setContentDisposition' . Just $ takeFileName fileReferenceTitle
  let cType = simpleContentType (mimeLookup $ pack fileReferenceTitle) <> "; charset=utf-8"
  join . runDB $ respondFileConditional Nothing cType fRef

-- | Serve a single file, identified through a given DB query
serveOneFile :: forall file.
                ( HasFileReference file
                , BearerAuthSite UniWorX
                , YesodPersistBackend UniWorX ~ SqlBackend
                , YesodPersistRunner UniWorX
                ) => ConduitT () file (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent
serveOneFile source = do
  results <- runDB . runConduit $ source .| C.take 2 .| C.foldMap pure -- We don't need more than two files to make a decision below
  ensureApprootUserGeneratedMaybe' . Just . yieldMany $ map (views (_FileReference . _1) Left) results
  case results of
    [file] -> sendFileReference file
    []     -> notFound
    _other -> do
      $logErrorS "SFileR" "Multiple matching files found."
      error "Multiple matching files found."

-- | Serve one file directly or a zip-archive of files, identified through a given DB query
--
-- Like `serveOneFile`, but sends a zip-archive if multiple results are returned
serveSomeFiles :: forall file.
                  ( HasFileReference file
                  , BearerAuthSite UniWorX
                  , YesodPersistBackend UniWorX ~ SqlBackend
                  , YesodPersistRunner UniWorX
                  ) => FilePath -> ConduitT () file (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent
serveSomeFiles archiveName source = serveSomeFiles' archiveName $ source .| C.map Left

serveSomeFiles' :: forall file.
                   ( HasFileReference file
                   , BearerAuthSite UniWorX
                   , YesodPersistBackend UniWorX ~ SqlBackend
                   , YesodPersistRunner UniWorX
                   ) => FilePath -> ConduitT () (Either file DBFile) (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent
serveSomeFiles' archiveName source = do
  (source', results) <- runDB $ runPeekN 2 source
  ensureApprootUserGeneratedMaybe' . Just . yieldMany $ over (traverse . _Left) (view $ _FileReference . _1) results

  $logDebugS "serveSomeFiles" . tshow $ length results

  case results of
    []         -> notFound
    [file]     -> either sendFileReference sendThisFile file
    _moreFiles -> do
      setCSPSandbox
      setContentDisposition' $ Just archiveName
      respondSourceDB typeZip $ do
        let zipComment = encodeUtf8 $ pack archiveName
        source' .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| C.map toFlushBuilder

-- | Serve any number of files as a zip-archive of files, identified through a given DB query
--
-- Like `serveSomeFiles`, but always sends a zip-archive, even if a single file is returned
serveZipArchive :: forall file.
                   ( HasFileReference file
                   , BearerAuthSite UniWorX
                   , YesodPersistBackend UniWorX ~ SqlBackend
                   , YesodPersistRunner UniWorX
                   ) => FilePath -> ConduitT () file (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent
serveZipArchive archiveName source = serveZipArchive' archiveName $ source .| C.map Left

serveZipArchive' :: forall file.
                    ( HasFileReference file
                    , BearerAuthSite UniWorX
                    , YesodPersistBackend UniWorX ~ SqlBackend
                    , YesodPersistRunner UniWorX
                    ) => FilePath -> ConduitT () (Either file DBFile) (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent
serveZipArchive' archiveName source = do
  (source', results) <- runDB $ runPeekN 1 source

  $logDebugS "serveZipArchive" . tshow $ length results

  case results of
    []         -> notFound
    _moreFiles -> do
      setCSPSandbox
      setContentDisposition' $ Just archiveName
      respondSourceDB typeZip $ do
        let zipComment = encodeUtf8 $ pack archiveName
        source' .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| C.map toFlushBuilder
