src/Gargantext/API/Node/File.hs

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