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