{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-matches #-}

{-# LANGUAGE AllowAmbiguousTypes     #-}
{-# LANGUAGE TypeOperators     #-}

module Gargantext.API.Node.File where

import Control.Lens ((^.))
import Data.Swagger
import Data.Text
import GHC.Generics (Generic)
import Servant
import Servant.Job.Async (JobFunction(..), serveJobsAPI)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.MIME.Types as DMT
import qualified Gargantext.Database.GargDB as GargDB
import qualified Network.HTTP.Media as M

import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.API.Node.Types
import Gargantext.API.Prelude
import Gargantext.Core.Types (TODO)
import Gargantext.Database.Action.Flow.Types
import Gargantext.Database.Action.Node (mkNodeWithParent)
import Gargantext.Database.Admin.Types.Hyperdata.File
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Query.Table.Node (getNodeWith)
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Schema.Node (node_hyperdata)
import Gargantext.Prelude

data RESPONSE deriving Typeable

instance Accept RESPONSE where
  contentType :: Proxy RESPONSE -> MediaType
contentType Proxy RESPONSE
_ = ByteString
"text" ByteString -> ByteString -> MediaType
M.// ByteString
"*"

instance MimeRender RESPONSE BSResponse where
  mimeRender :: Proxy RESPONSE -> BSResponse -> ByteString
mimeRender Proxy RESPONSE
_ (BSResponse ByteString
val) = ByteString -> ByteString
BSL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
val

type FileApi = Summary "File download"
            :> "download"
            :> Get '[RESPONSE] (Headers '[Servant.Header "Content-Type" Text] BSResponse)

fileApi :: UserId -> NodeId -> GargServer FileApi
fileApi :: UserId -> NodeId -> GargServer FileApi
fileApi UserId
uId NodeId
nId = UserId
-> NodeId -> m (Headers '[Header "Content-Type" Text] BSResponse)
forall env err (m :: * -> *).
(HasSettings env, FlowCmdM env err m) =>
UserId
-> NodeId -> m (Headers '[Header "Content-Type" Text] BSResponse)
fileDownload UserId
uId NodeId
nId

newtype Contents = Contents BS.ByteString

instance GargDB.ReadFile Contents where
  readFile' :: FilePath -> IO Contents
readFile' FilePath
fp = do
    ByteString
c <- FilePath -> IO ByteString
BS.readFile FilePath
fp
    Contents -> IO Contents
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Contents -> IO Contents) -> Contents -> IO Contents
forall a b. (a -> b) -> a -> b
$ ByteString -> Contents
Contents ByteString
c

newtype BSResponse = BSResponse BS.ByteString
  deriving ((forall x. BSResponse -> Rep BSResponse x)
-> (forall x. Rep BSResponse x -> BSResponse) -> Generic BSResponse
forall x. Rep BSResponse x -> BSResponse
forall x. BSResponse -> Rep BSResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BSResponse x -> BSResponse
$cfrom :: forall x. BSResponse -> Rep BSResponse x
Generic)

instance ToSchema BSResponse  where
  declareNamedSchema :: Proxy BSResponse -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy BSResponse
_ = Proxy TODO -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy TODO
forall k (t :: k). Proxy t
Proxy :: Proxy TODO)

fileDownload :: (HasSettings env, FlowCmdM env err m)
             => UserId
             -> NodeId
             -> m (Headers '[Servant.Header "Content-Type" Text] BSResponse)
fileDownload :: UserId
-> NodeId -> m (Headers '[Header "Content-Type" Text] BSResponse)
fileDownload UserId
uId NodeId
nId = do
  FilePath -> UserId -> m ()
forall a (m :: * -> *).
(Show a, MonadBase IO m) =>
FilePath -> a -> m ()
printDebug FilePath
"[fileDownload] uId" UserId
uId
  FilePath -> NodeId -> m ()
forall a (m :: * -> *).
(Show a, MonadBase IO m) =>
FilePath -> a -> m ()
printDebug FilePath
"[fileDownload] nId" NodeId
nId

  Node HyperdataFile
node <- NodeId -> Proxy HyperdataFile -> Cmd err (Node HyperdataFile)
forall err a (proxy :: * -> *).
(HasNodeError err, JSONB a) =>
NodeId -> proxy a -> Cmd err (Node a)
getNodeWith NodeId
nId (Proxy HyperdataFile
forall k (t :: k). Proxy t
Proxy :: Proxy HyperdataFile)
  let (HyperdataFile { _hff_name :: HyperdataFile -> Text
_hff_name = Text
name'
                     , _hff_path :: HyperdataFile -> Text
_hff_path = Text
path }) = Node HyperdataFile
node Node HyperdataFile
-> Getting HyperdataFile (Node HyperdataFile) HyperdataFile
-> HyperdataFile
forall s a. s -> Getting a s a -> a
^. Getting HyperdataFile (Node HyperdataFile) HyperdataFile
forall id hash_id typename user_id parent_id name date hyperdata1
       hyperdata2.
Lens
  (NodePoly
     id hash_id typename user_id parent_id name date hyperdata1)
  (NodePoly
     id hash_id typename user_id parent_id name date hyperdata2)
  hyperdata1
  hyperdata2
node_hyperdata

  Contents ByteString
c <- FilePath -> m Contents
forall env (m :: * -> *) a.
(MonadReader env m, HasConfig env, MonadBase IO m, ReadFile a) =>
FilePath -> m a
GargDB.readFile (FilePath -> m Contents) -> FilePath -> m Contents
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
unpack Text
path

  let (Maybe FilePath
mMime, Maybe FilePath
_) = MIMETypeData
-> Bool -> FilePath -> (Maybe FilePath, Maybe FilePath)
DMT.guessType MIMETypeData
DMT.defaultmtd Bool
False (FilePath -> (Maybe FilePath, Maybe FilePath))
-> FilePath -> (Maybe FilePath, Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
unpack Text
name'
      mime :: FilePath
mime = case Maybe FilePath
mMime of
        Just FilePath
m  -> FilePath
m
        Maybe FilePath
Nothing -> FilePath
"text/plain"

  Headers '[Header "Content-Type" Text] BSResponse
-> m (Headers '[Header "Content-Type" Text] BSResponse)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Headers '[Header "Content-Type" Text] BSResponse
 -> m (Headers '[Header "Content-Type" Text] BSResponse))
-> Headers '[Header "Content-Type" Text] BSResponse
-> m (Headers '[Header "Content-Type" Text] BSResponse)
forall a b. (a -> b) -> a -> b
$ Text
-> BSResponse -> Headers '[Header "Content-Type" Text] BSResponse
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader (FilePath -> Text
pack FilePath
mime) (BSResponse -> Headers '[Header "Content-Type" Text] BSResponse)
-> BSResponse -> Headers '[Header "Content-Type" Text] BSResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> BSResponse
BSResponse ByteString
c
 
  --pure c

  -- let settings = embeddedSettings [("", encodeUtf8 c)]

  -- Tagged $ staticApp settings

  -- let settings = embeddedSettings [("", "hello")]
  -- Tagged $ staticApp settings

type FileAsyncApi = Summary "File Async Api"
                 :> "file"
                 :> "add"
                 :> AsyncJobs JobLog '[FormUrlEncoded] NewWithFile JobLog

fileAsyncApi :: UserId -> NodeId -> GargServer FileAsyncApi
fileAsyncApi :: UserId -> NodeId -> GargServer FileAsyncApi
fileAsyncApi UserId
uId NodeId
nId =
  JobFunction env err JobLog NewWithFile JobLog
-> AsyncJobsServerT' Any Any Maybe JobLog NewWithFile JobLog m
forall (callbacks :: * -> *) env err (m :: * -> *) event input
       output (ctI :: [*]) (ctO :: [*]).
(MonadAsyncJobs' callbacks env err event output m,
 MimeRender JSON input) =>
JobFunction env err event input output
-> AsyncJobsServerT' ctI ctO callbacks event input output m
serveJobsAPI (JobFunction env err JobLog NewWithFile JobLog
 -> AsyncJobsServerT' Any Any Maybe JobLog NewWithFile JobLog m)
-> JobFunction env err JobLog NewWithFile JobLog
-> AsyncJobsServerT' Any Any Maybe JobLog NewWithFile JobLog m
forall a b. (a -> b) -> a -> b
$
    (forall (m :: * -> *).
 (MonadReader env m, MonadError err m, MonadBaseControl IO m) =>
 NewWithFile -> (JobLog -> IO ()) -> m JobLog)
-> JobFunction env err JobLog NewWithFile JobLog
forall env err event input output.
(forall (m :: * -> *).
 (MonadReader env m, MonadError err m, MonadBaseControl IO m) =>
 input -> (event -> IO ()) -> m output)
-> JobFunction env err event input output
JobFunction (\NewWithFile
i JobLog -> IO ()
l ->
      let
        log' :: JobLog -> m ()
log' JobLog
x = do
          FilePath -> JobLog -> m ()
forall a (m :: * -> *).
(Show a, MonadBase IO m) =>
FilePath -> a -> m ()
printDebug FilePath
"addWithFile" JobLog
x
          IO () -> m ()
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ JobLog -> IO ()
l JobLog
x
      in UserId -> NodeId -> NewWithFile -> (JobLog -> m ()) -> m JobLog
forall env err (m :: * -> *).
(HasSettings env, FlowCmdM env err m) =>
UserId -> NodeId -> NewWithFile -> (JobLog -> m ()) -> m JobLog
addWithFile UserId
uId NodeId
nId NewWithFile
i JobLog -> m ()
forall (m :: * -> *). MonadBase IO m => JobLog -> m ()
log')


addWithFile :: (HasSettings env, FlowCmdM env err m)
            => UserId
            -> NodeId
            -> NewWithFile
            -> (JobLog -> m ())
            -> m JobLog
addWithFile :: UserId -> NodeId -> NewWithFile -> (JobLog -> m ()) -> m JobLog
addWithFile UserId
uId NodeId
nId nwf :: NewWithFile
nwf@(NewWithFile Text
_d Maybe Lang
_l Text
fName) JobLog -> m ()
logStatus = do

  FilePath -> NodeId -> m ()
forall a (m :: * -> *).
(Show a, MonadBase IO m) =>
FilePath -> a -> m ()
printDebug FilePath
"[addWithFile] Uploading file: " NodeId
nId
  JobLog -> m ()
logStatus JobLog :: Maybe UserId
-> Maybe UserId -> Maybe UserId -> Maybe [ScraperEvent] -> JobLog
JobLog { _scst_succeeded :: Maybe UserId
_scst_succeeded = UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
0
                   , _scst_failed :: Maybe UserId
_scst_failed    = UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
0
                   , _scst_remaining :: Maybe UserId
_scst_remaining = UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
1
                   , _scst_events :: Maybe [ScraperEvent]
_scst_events    = [ScraperEvent] -> Maybe [ScraperEvent]
forall a. a -> Maybe a
Just []
                   }

  FilePath
fPath <- NewWithFile -> m FilePath
forall env (m :: * -> *) a.
(MonadReader env m, HasConfig env, MonadBase IO m, SaveFile a) =>
a -> m FilePath
GargDB.writeFile NewWithFile
nwf
  FilePath -> FilePath -> m ()
forall a (m :: * -> *).
(Show a, MonadBase IO m) =>
FilePath -> a -> m ()
printDebug FilePath
"[addWithFile] File saved as: " FilePath
fPath

  [NodeId]
nIds <- NodeType -> Maybe NodeId -> UserId -> Text -> Cmd err [NodeId]
forall err.
(HasNodeError err, HasDBid NodeType) =>
NodeType -> Maybe NodeId -> UserId -> Text -> Cmd err [NodeId]
mkNodeWithParent NodeType
NodeFile (NodeId -> Maybe NodeId
forall a. a -> Maybe a
Just NodeId
nId) UserId
uId Text
fName

  ()
_ <- case [NodeId]
nIds of
    [NodeId
nId'] -> do
        Node HyperdataFile
node <- NodeId -> Proxy HyperdataFile -> Cmd err (Node HyperdataFile)
forall err a (proxy :: * -> *).
(HasNodeError err, JSONB a) =>
NodeId -> proxy a -> Cmd err (Node a)
getNodeWith NodeId
nId' (Proxy HyperdataFile
forall k (t :: k). Proxy t
Proxy :: Proxy HyperdataFile)
        let hl :: HyperdataFile
hl = Node HyperdataFile
node Node HyperdataFile
-> Getting HyperdataFile (Node HyperdataFile) HyperdataFile
-> HyperdataFile
forall s a. s -> Getting a s a -> a
^. Getting HyperdataFile (Node HyperdataFile) HyperdataFile
forall id hash_id typename user_id parent_id name date hyperdata1
       hyperdata2.
Lens
  (NodePoly
     id hash_id typename user_id parent_id name date hyperdata1)
  (NodePoly
     id hash_id typename user_id parent_id name date hyperdata2)
  hyperdata1
  hyperdata2
node_hyperdata
        Int64
_ <- NodeId -> HyperdataFile -> Cmd err Int64
forall a err. ToJSON a => NodeId -> a -> Cmd err Int64
updateHyperdata NodeId
nId' (HyperdataFile -> Cmd err Int64) -> HyperdataFile -> Cmd err Int64
forall a b. (a -> b) -> a -> b
$ HyperdataFile
hl { _hff_name :: Text
_hff_name = Text
fName
                                       , _hff_path :: Text
_hff_path = FilePath -> Text
pack FilePath
fPath }

        FilePath -> NodeId -> m ()
forall a (m :: * -> *).
(Show a, MonadBase IO m) =>
FilePath -> a -> m ()
printDebug FilePath
"[addWithFile] Created node with id: " NodeId
nId'
    [NodeId]
_     -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  FilePath -> NodeId -> m ()
forall a (m :: * -> *).
(Show a, MonadBase IO m) =>
FilePath -> a -> m ()
printDebug FilePath
"[addWithFile] File upload finished: " NodeId
nId
  JobLog -> m JobLog
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JobLog -> m JobLog) -> JobLog -> m JobLog
forall a b. (a -> b) -> a -> b
$ JobLog :: Maybe UserId
-> Maybe UserId -> Maybe UserId -> Maybe [ScraperEvent] -> JobLog
JobLog { _scst_succeeded :: Maybe UserId
_scst_succeeded = UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
1
                , _scst_failed :: Maybe UserId
_scst_failed    = UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
0
                , _scst_remaining :: Maybe UserId
_scst_remaining = UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
0
                , _scst_events :: Maybe [ScraperEvent]
_scst_events    = [ScraperEvent] -> Maybe [ScraperEvent]
forall a. a -> Maybe a
Just []
                }