src/Gargantext/API/Node/File.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-matches #-}
   2
   3 {-# LANGUAGE AllowAmbiguousTypes     #-}
   4 {-# LANGUAGE TypeOperators     #-}
   5
   6 module Gargantext.API.Node.File where
   7
   8 import Control.Lens ((^.))
   9 import qualified Data.ByteString as BS
  10 import qualified Data.ByteString.Lazy as BSL
  11 import qualified Data.MIME.Types as DMT
  12 import Data.Swagger
  13 import Data.Text
  14 import GHC.Generics (Generic)
  15 import qualified Network.HTTP.Media as M
  16 import Servant
  17 import Servant.Job.Async (JobFunction(..), serveJobsAPI)
  18
  19 import Gargantext.Prelude
  20 import qualified Gargantext.Prelude.Utils as GPU
  21
  22 import Gargantext.Core.Types (TODO)
  23 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
  24 import Gargantext.API.Admin.Types (HasSettings)
  25 import Gargantext.API.Node.Types
  26 import Gargantext.API.Prelude
  27 import Gargantext.Database.Action.Flow.Types
  28 import Gargantext.Database.Action.Node (mkNodeWithParent)
  29 import Gargantext.Database.Admin.Types.Hyperdata.File
  30 import Gargantext.Database.Admin.Types.Node
  31 import Gargantext.Database.Query.Table.Node (getNodeWith)
  32 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  33 import Gargantext.Database.Schema.Node (node_hyperdata)
  34
  35 data RESPONSE deriving Typeable
  36
  37 instance Accept RESPONSE where
  38   contentType _ = "text" M.// "*"
  39
  40 instance MimeRender RESPONSE BSResponse where
  41   mimeRender _ (BSResponse val) = BSL.fromStrict $ val
  42
  43 type FileApi = Summary "File download"
  44             :> "download"
  45             :> Get '[RESPONSE] (Headers '[Servant.Header "Content-Type" Text] BSResponse)
  46
  47 fileApi :: UserId -> NodeId -> GargServer FileApi
  48 fileApi uId nId = fileDownload uId nId
  49
  50 newtype Contents = Contents BS.ByteString
  51
  52 instance GPU.ReadFile Contents where
  53   readFile' fp = do
  54     c <- BS.readFile fp
  55     pure $ Contents c
  56
  57 newtype BSResponse = BSResponse BS.ByteString
  58   deriving (Generic)
  59
  60 instance ToSchema BSResponse  where
  61   declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
  62
  63 fileDownload :: (HasSettings env, FlowCmdM env err m)
  64              => UserId
  65              -> NodeId
  66              -> m (Headers '[Servant.Header "Content-Type" Text] BSResponse)
  67 fileDownload uId nId = do
  68   printDebug "[fileDownload] uId" uId
  69   printDebug "[fileDownload] nId" nId
  70
  71   node <- getNodeWith nId (Proxy :: Proxy HyperdataFile)
  72   let (HyperdataFile { _hff_name = name'
  73                      , _hff_path = path }) = node ^. node_hyperdata
  74
  75   Contents c <- GPU.readFile $ unpack path
  76
  77   let (mMime, _) = DMT.guessType DMT.defaultmtd False $ unpack name'
  78       mime = case mMime of
  79         Just m  -> m
  80         Nothing -> "text/plain"
  81
  82   pure $ addHeader (pack mime) $ BSResponse c
  83
  84   --pure c
  85
  86   -- let settings = embeddedSettings [("", encodeUtf8 c)]
  87
  88   -- Tagged $ staticApp settings
  89
  90   -- let settings = embeddedSettings [("", "hello")]
  91   -- Tagged $ staticApp settings
  92
  93 type FileAsyncApi = Summary "File Async Api"
  94                  :> "file"
  95                  :> "add"
  96                  :> AsyncJobs JobLog '[FormUrlEncoded] NewWithFile JobLog
  97
  98 fileAsyncApi :: UserId -> NodeId -> GargServer FileAsyncApi
  99 fileAsyncApi uId nId =
 100   serveJobsAPI $
 101     JobFunction (\i l ->
 102       let
 103         log' x = do
 104           printDebug "addWithFile" x
 105           liftBase $ l x
 106       in addWithFile uId nId i log')
 107
 108
 109 addWithFile :: (HasSettings env, FlowCmdM env err m)
 110             => UserId
 111             -> NodeId
 112             -> NewWithFile
 113             -> (JobLog -> m ())
 114             -> m JobLog
 115 addWithFile uId nId nwf@(NewWithFile _d _l fName) logStatus = do
 116
 117   printDebug "[addWithFile] Uploading file: " nId
 118   logStatus JobLog { _scst_succeeded = Just 0
 119                    , _scst_failed    = Just 0
 120                    , _scst_remaining = Just 1
 121                    , _scst_events    = Just []
 122                    }
 123
 124   fPath <- GPU.writeFile nwf
 125   printDebug "[addWithFile] File saved as: " fPath
 126
 127   nIds <- mkNodeWithParent NodeFile (Just nId) uId fName
 128
 129   _ <- case nIds of
 130     [nId'] -> do
 131         node <- getNodeWith nId' (Proxy :: Proxy HyperdataFile)
 132         let hl = node ^. node_hyperdata
 133         _ <- updateHyperdata nId' $ hl { _hff_name = fName
 134                                        , _hff_path = pack fPath }
 135
 136         printDebug "[addWithFile] Created node with id: " nId'
 137     _     -> pure ()
 138
 139   printDebug "[addWithFile] File upload finished: " nId
 140   pure $ JobLog { _scst_succeeded = Just 1
 141                 , _scst_failed    = Just 0
 142                 , _scst_remaining = Just 0
 143                 , _scst_events    = Just []
 144                 }