src/Gargantext/API.hs

   1 {-|
   2 Module      : Gargantext.API
   3 Description : REST API declaration
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Main (RESTful) API of the instance Gargantext.
  11
  12 The Garg-API is typed to derive the documentation, the mock and tests.
  13
  14 This API is indeed typed in order to be able to derive both the server
  15 and the client sides.
  16
  17 The Garg-API-Monad enables:
  18   - Security (WIP)
  19   - Features (WIP)
  20   - Database connection (long term)
  21   - In Memory stack management (short term)
  22   - Logs (WIP)
  23
  24 Thanks to Yann Esposito for our discussions at the start and to Nicolas
  25 Pouillard (who mainly made it).
  26
  27 -}
  28
  29 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  30
  31 {-# LANGUAGE ConstraintKinds      #-}
  32 {-# LANGUAGE TemplateHaskell      #-}
  33 {-# LANGUAGE TypeOperators        #-}
  34 {-# LANGUAGE KindSignatures       #-}
  35 {-# LANGUAGE ScopedTypeVariables  #-}
  36 {-# LANGUAGE TypeFamilies         #-}
  37 {-# LANGUAGE UndecidableInstances #-}
  38
  39 ---------------------------------------------------------------------
  40 module Gargantext.API
  41       where
  42 ---------------------------------------------------------------------
  43 import Control.Exception (finally)
  44 import Control.Lens
  45 import Control.Monad.Except (withExceptT)
  46 import Control.Monad.Reader (runReaderT)
  47 import Data.Aeson.Encode.Pretty (encodePretty)
  48 import Data.List (lookup)
  49 import Data.Swagger
  50 import Data.Text (Text)
  51 import Data.Text.Encoding (encodeUtf8)
  52 import Data.Validity
  53 import Data.Version (showVersion)
  54 import GHC.Base (Applicative)
  55 import GHC.Generics (D1, Meta (..), Rep, Generic)
  56 import GHC.TypeLits (AppendSymbol, Symbol)
  57 import Gargantext.API.Admin.Auth (AuthContext, auth)
  58 import Gargantext.API.Admin.FrontEnd (frontEndServer)
  59 import Gargantext.API.Admin.Settings
  60 import Gargantext.API.Ngrams (HasRepoSaver(..), saveRepo)
  61 import Gargantext.API.Prelude
  62 import Gargantext.API.Routes
  63 import Gargantext.Prelude
  64 import Network.HTTP.Types hiding (Query)
  65 import Network.Wai
  66 import Network.Wai (Request, requestHeaders)
  67 import Network.Wai.Handler.Warp hiding (defaultSettings)
  68 import Network.Wai.Middleware.Cors
  69 import Network.Wai.Middleware.RequestLogger
  70 import Servant
  71 import Servant.Auth.Server (AuthResult(..))
  72 import Servant.Auth.Swagger ()
  73 import Servant.Swagger
  74 import Servant.Swagger.UI
  75 import System.IO (FilePath)
  76 import qualified Data.ByteString.Lazy.Char8 as BL8
  77 import qualified Data.Text.IO               as T
  78 import qualified Paths_gargantext           as PG -- cabal magic build module
  79
  80
  81 data Mode = Dev | Mock | Prod
  82        deriving (Show, Read, Generic)
  83
  84
  85 -- | startGargantext takes as parameters port number and Ini file.
  86 startGargantext :: Mode -> PortNumber -> FilePath -> IO ()
  87 startGargantext mode port file = do
  88   env <- newEnv port file
  89   portRouteInfo port
  90   app <- makeApp env
  91   mid <- makeDevMiddleware mode
  92   run port (mid app) `finally` stopGargantext env
  93
  94 portRouteInfo :: PortNumber -> IO ()
  95 portRouteInfo port = do
  96   T.putStrLn "      ----Main Routes-----      "
  97   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
  98   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
  99
 100 -- TODO clean this Monad condition (more generic) ?
 101 stopGargantext :: HasRepoSaver env => env -> IO ()
 102 stopGargantext env = do
 103   T.putStrLn "----- Stopping gargantext -----"
 104   runReaderT saveRepo env
 105
 106
 107 -- | Output generated @swagger.json@ file for the @'TodoAPI'@.
 108 swaggerWriteJSON :: IO ()
 109 swaggerWriteJSON = BL8.writeFile "swagger.json" (encodePretty swaggerDoc)
 110
 111 -- | Swagger Specifications
 112 swaggerDoc :: Swagger
 113 swaggerDoc = toSwagger (Proxy :: Proxy GargAPI)
 114   & info.title       .~ "Gargantext"
 115   & info.version     .~ (cs $ showVersion PG.version)
 116   -- & info.base_url     ?~ (URL "http://gargantext.org/")
 117   & info.description ?~ "REST API specifications"
 118   -- & tags             .~ Set.fromList [Tag "Garg" (Just "Main perations") Nothing]
 119   & applyTagsFor (subOperations (Proxy :: Proxy GargAPI)(Proxy :: Proxy GargAPI))
 120                  ["Gargantext" & description ?~ "Main operations"]
 121   & info.license     ?~ ("AGPLV3 (English) and CECILL (French)" & url ?~ URL urlLicence )
 122     where
 123         urlLicence = "https://gitlab.iscpif.fr/gargantext/haskell-gargantext/blob/master/LICENSE"
 124
 125 {-
 126 startGargantextMock :: PortNumber -> IO ()
 127 startGargantextMock port = do
 128   portRouteInfo port
 129   application <- makeMockApp . MockEnv $ FireWall False
 130   run port application
 131 -}
 132
 133 ----------------------------------------------------------------------
 134
 135 fireWall :: Applicative f => Request -> FireWall -> f Bool
 136 fireWall req fw = do
 137     let origin = lookup "Origin" (requestHeaders req)
 138     let host   = lookup "Host"   (requestHeaders req)
 139
 140     if  origin == Just (encodeUtf8 "http://localhost:8008")
 141        && host == Just (encodeUtf8 "localhost:3000")
 142        || (not $ unFireWall fw)
 143
 144        then pure True
 145        else pure False
 146
 147 {-
 148 -- makeMockApp :: Env -> IO (Warp.Settings, Application)
 149 makeMockApp :: MockEnv -> IO Application
 150 makeMockApp env = do
 151     let serverApp = appMock
 152
 153     -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 154     --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 155     let checkOriginAndHost app req resp = do
 156             blocking <- fireWall req (env ^. menv_firewall)
 157             case blocking  of
 158                 True  -> app req resp
 159                 False -> resp ( responseLBS status401 []
 160                               "Invalid Origin or Host header")
 161
 162     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 163 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 164             { corsOrigins        = Nothing --  == /*
 165             , corsMethods        = [ methodGet   , methodPost   , methodPut
 166                                    , methodDelete, methodOptions, methodHead]
 167             , corsRequestHeaders = ["authorization", "content-type"]
 168             , corsExposedHeaders = Nothing
 169             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 170             , corsVaryOrigin     = False
 171             , corsRequireOrigin  = False
 172             , corsIgnoreFailures = False
 173             }
 174
 175     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 176     --          $ Warp.defaultSettings
 177
 178     --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
 179     pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp
 180 -}
 181
 182
 183 makeDevMiddleware :: Mode -> IO Middleware
 184 makeDevMiddleware mode = do
 185
 186     -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 187     --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 188 --    let checkOriginAndHost app req resp = do
 189 --            blocking <- fireWall req (env ^. menv_firewall)
 190 --            case blocking  of
 191 --                True  -> app req resp
 192 --                False -> resp ( responseLBS status401 []
 193 --                              "Invalid Origin or Host header")
 194 --
 195     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 196 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 197             { corsOrigins        = Nothing --  == /*
 198             , corsMethods        = [ methodGet   , methodPost   , methodPut
 199                                    , methodDelete, methodOptions, methodHead]
 200             , corsRequestHeaders = ["authorization", "content-type"]
 201             , corsExposedHeaders = Nothing
 202             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 203             , corsVaryOrigin     = False
 204             , corsRequireOrigin  = False
 205             , corsIgnoreFailures = False
 206             }
 207
 208     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 209     --          $ Warp.defaultSettings
 210
 211     --pure (warpS, logWare . checkOriginAndHost . corsMiddleware)
 212     case mode of
 213       Prod -> pure $ logStdout . corsMiddleware
 214       _    -> pure $ logStdoutDev . corsMiddleware
 215
 216 ---------------------------------------------------------------------
 217 -- | API Global
 218 ---------------------------------------------------------------------
 219 -- | Server declarations
 220 server :: forall env. EnvC env => env -> IO (Server API)
 221 server env = do
 222   -- orchestrator <- scrapyOrchestrator env
 223   pure $  schemaUiServer swaggerDoc
 224      :<|> hoistServerWithContext
 225             (Proxy :: Proxy GargAPI)
 226             (Proxy :: Proxy AuthContext)
 227             transform
 228             serverGargAPI
 229      :<|> frontEndServer
 230   where
 231     transform :: forall a. GargServerM env GargError a -> Handler a
 232     transform = Handler . withExceptT showAsServantErr . (`runReaderT` env)
 233
 234 showAsServantErr :: GargError -> ServerError
 235 showAsServantErr (GargServerError err) = err
 236 showAsServantErr a = err500 { errBody = BL8.pack $ show a }
 237
 238 ---------------------------
 239
 240 serverGargAPI :: GargServerT env err (GargServerM env err) GargAPI
 241 serverGargAPI -- orchestrator
 242        =  auth
 243      :<|> gargVersion
 244      :<|> serverPrivateGargAPI
 245   --   :<|> orchestrator
 246   where
 247
 248     gargVersion :: GargServer GargVersion
 249     gargVersion = pure (cs $ showVersion PG.version)
 250
 251     serverPrivateGargAPI :: GargServerT env err (GargServerM env err) GargPrivateAPI
 252     serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
 253     serverPrivateGargAPI _                     = throwAll' (_ServerError # err401)
 254 -- Here throwAll' requires a concrete type for the monad.
 255
 256
 257 -- TODO-SECURITY admin only: withAdmin
 258 -- Question: How do we mark admins?
 259 {-
 260 serverGargAdminAPI :: GargServer GargAdminAPI
 261 serverGargAdminAPI =  roots
 262                  :<|> nodesAPI
 263 -}
 264
 265 ---------------------------------------------------------------------
 266 --gargMock :: Server GargAPI
 267 --gargMock = mock apiGarg Proxy
 268 ---------------------------------------------------------------------
 269 makeApp :: EnvC env => env -> IO Application
 270 makeApp env = serveWithContext api cfg <$> server env
 271   where
 272     cfg :: Servant.Context AuthContext
 273     cfg = env ^. settings . jwtSettings
 274        :. env ^. settings . cookieSettings
 275     -- :. authCheck env
 276        :. EmptyContext
 277
 278 --appMock :: Application
 279 --appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
 280 ---------------------------------------------------------------------
 281 api :: Proxy API
 282 api  = Proxy
 283
 284 apiGarg :: Proxy GargAPI
 285 apiGarg  = Proxy
 286 ---------------------------------------------------------------------
 287 schemaUiServer :: (Server api ~ Handler Swagger)
 288         => Swagger -> Server (SwaggerSchemaUI' dir api)
 289 schemaUiServer = swaggerSchemaUIServer
 290
 291 ---------------------------------------------------------------------
 292 -- Type Family for the Documentation
 293 type family TypeName (x :: *) :: Symbol where
 294     TypeName Int  = "Int"
 295     TypeName Text = "Text"
 296     TypeName x    = GenericTypeName x (Rep x ())
 297
 298 type family GenericTypeName t (r :: *) :: Symbol where
 299     GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
 300
 301 type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
 302
 303