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 Network.HTTP.Types hiding (Query)
  58 import Network.Wai
  59 import Network.Wai.Handler.Warp hiding (defaultSettings)
  60 import Network.Wai.Middleware.Cors
  61 import Network.Wai.Middleware.RequestLogger
  62 import Servant
  63 import Servant.Auth.Server (AuthResult(..))
  64 import Servant.Auth.Swagger ()
  65 import Servant.Swagger
  66 import Servant.Swagger.UI
  67 import System.IO (FilePath)
  68 import qualified Data.ByteString.Lazy.Char8 as BL8
  69 import qualified Data.Text.IO               as T
  70 import qualified Paths_gargantext           as PG -- cabal magic build module
  71
  72 import qualified Gargantext.API.Public      as Public
  73
  74 import Gargantext.Prelude.Config (gc_url_backend_api)
  75 import Gargantext.API.Admin.Auth (AuthContext, auth)
  76 import Gargantext.API.Admin.FrontEnd (frontEndServer)
  77 import Gargantext.API.Admin.Settings (newEnv)
  78 import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, env_gargConfig, jwtSettings, settings)
  79 import Gargantext.API.Ngrams (saveRepo)
  80 import Gargantext.API.Ngrams.Types (HasRepoSaver(..))
  81 import Gargantext.API.Prelude
  82 import Gargantext.API.Routes
  83 import Gargantext.Prelude
  84
  85
  86 data Mode = Dev | Mock | Prod
  87        deriving (Show, Read, Generic)
  88
  89 -- | startGargantext takes as parameters port number and Ini file.
  90 startGargantext :: Mode -> PortNumber -> FilePath -> IO ()
  91 startGargantext mode port file = do
  92   env <- newEnv port file
  93   portRouteInfo port
  94
  95   let baseUrl = env ^. env_gargConfig . gc_url_backend_api
  96   app <- makeApp env baseUrl
  97
  98   mid <- makeDevMiddleware mode
  99   run port (mid app) `finally` stopGargantext env
 100
 101 portRouteInfo :: PortNumber -> IO ()
 102 portRouteInfo port = do
 103   T.putStrLn "      ----Main Routes-----      "
 104   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
 105   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
 106
 107 -- TODO clean this Monad condition (more generic) ?
 108 stopGargantext :: HasRepoSaver env => env -> IO ()
 109 stopGargantext env = do
 110   T.putStrLn "----- Stopping gargantext -----"
 111   runReaderT saveRepo env
 112
 113 -- | Output generated @swagger.json@ file for the @'TodoAPI'@.
 114 swaggerWriteJSON :: IO ()
 115 swaggerWriteJSON = BL8.writeFile "swagger.json" (encodePretty swaggerDoc)
 116
 117 -- | Swagger Specifications
 118 swaggerDoc :: Swagger
 119 swaggerDoc = toSwagger (Proxy :: Proxy GargAPI)
 120   & info.title       .~ "Gargantext"
 121   & info.version     .~ (cs $ showVersion PG.version)
 122   -- & info.base_url     ?~ (URL "http://gargantext.org/")
 123   & info.description ?~ "REST API specifications"
 124   -- & tags             .~ Set.fromList [Tag "Garg" (Just "Main perations") Nothing]
 125   & applyTagsFor (subOperations (Proxy :: Proxy GargAPI)(Proxy :: Proxy GargAPI))
 126                  ["Gargantext" & description ?~ "Main operations"]
 127   & info.license     ?~ ("AGPLV3 (English) and CECILL (French)" & url ?~ URL urlLicence )
 128     where
 129         urlLicence = "https://gitlab.iscpif.fr/gargantext/haskell-gargantext/blob/master/LICENSE"
 130
 131 {-
 132 startGargantextMock :: PortNumber -> IO ()
 133 startGargantextMock port = do
 134   portRouteInfo port
 135   application <- makeMockApp . MockEnv $ FireWall False
 136   run port application
 137 -}
 138
 139 ----------------------------------------------------------------------
 140
 141 fireWall :: Applicative f => Request -> FireWall -> f Bool
 142 fireWall req fw = do
 143     let origin = lookup "Origin" (requestHeaders req)
 144     let host   = lookup "Host"   (requestHeaders req)
 145
 146     if  origin == Just (encodeUtf8 "http://localhost:8008")
 147        && host == Just (encodeUtf8 "localhost:3000")
 148        || (not $ unFireWall fw)
 149
 150        then pure True
 151        else pure False
 152
 153 {-
 154 -- makeMockApp :: Env -> IO (Warp.Settings, Application)
 155 makeMockApp :: MockEnv -> IO Application
 156 makeMockApp env = do
 157     let serverApp = appMock
 158
 159     -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 160     --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 161     let checkOriginAndHost app req resp = do
 162             blocking <- fireWall req (env ^. menv_firewall)
 163             case blocking  of
 164                 True  -> app req resp
 165                 False -> resp ( responseLBS status401 []
 166                               "Invalid Origin or Host header")
 167
 168     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 169 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 170             { corsOrigins        = Nothing --  == /*
 171             , corsMethods        = [ methodGet   , methodPost   , methodPut
 172                                    , methodDelete, methodOptions, methodHead]
 173             , corsRequestHeaders = ["authorization", "content-type"]
 174             , corsExposedHeaders = Nothing
 175             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 176             , corsVaryOrigin     = False
 177             , corsRequireOrigin  = False
 178             , corsIgnoreFailures = False
 179             }
 180
 181     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 182     --          $ Warp.defaultSettings
 183
 184     --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
 185     pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp
 186 -}
 187
 188
 189 makeDevMiddleware :: Mode -> IO Middleware
 190 makeDevMiddleware mode = do
 191 -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 192 -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 193 --    let checkOriginAndHost app req resp = do
 194 --            blocking <- fireWall req (env ^. menv_firewall)
 195 --            case blocking  of
 196 --                True  -> app req resp
 197 --                False -> resp ( responseLBS status401 []
 198 --                              "Invalid Origin or Host header")
 199 --
 200     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 201 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 202             { corsOrigins        = Nothing --  == /*
 203             , corsMethods        = [ methodGet   , methodPost   , methodPut
 204                                    , methodDelete, methodOptions, methodHead]
 205             , corsRequestHeaders = ["authorization", "content-type"]
 206             , corsExposedHeaders = Nothing
 207             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 208             , corsVaryOrigin     = False
 209             , corsRequireOrigin  = False
 210             , corsIgnoreFailures = False
 211             }
 212
 213     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 214     --          $ Warp.defaultSettings
 215
 216     --pure (warpS, logWare . checkOriginAndHost . corsMiddleware)
 217     case mode of
 218       Prod -> pure $ logStdout . corsMiddleware
 219       _    -> pure $ logStdoutDev . corsMiddleware
 220
 221 ---------------------------------------------------------------------
 222 -- | API Global
 223 ---------------------------------------------------------------------
 224 -- | Server declarations
 225 server :: forall env. EnvC env => env -> Text -> IO (Server API)
 226 server env baseUrl = do
 227   -- orchestrator <- scrapyOrchestrator env
 228   pure $  schemaUiServer swaggerDoc
 229      :<|> hoistServerWithContext
 230             (Proxy :: Proxy GargAPI)
 231             (Proxy :: Proxy AuthContext)
 232             transform
 233             (serverGargAPI baseUrl)
 234      :<|> frontEndServer
 235   where
 236     transform :: forall a. GargServerM env GargError a -> Handler a
 237     transform = Handler . withExceptT showAsServantErr . (`runReaderT` env)
 238
 239
 240
 241 showAsServantErr :: GargError -> ServerError
 242 showAsServantErr (GargServerError err) = err
 243 showAsServantErr a = err500 { errBody = BL8.pack $ show a }
 244
 245 ---------------------------
 246
 247 serverGargAPI :: Text -> GargServerT env err (GargServerM env err) GargAPI
 248 serverGargAPI baseUrl -- orchestrator
 249        =  auth
 250      :<|> gargVersion
 251      :<|> serverPrivateGargAPI
 252      :<|> (Public.api baseUrl)
 253
 254   --   :<|> orchestrator
 255   where
 256     gargVersion :: GargServer GargVersion
 257     gargVersion = pure (cs $ showVersion PG.version)
 258
 259     serverPrivateGargAPI :: GargServerT env err (GargServerM env err) GargPrivateAPI
 260     serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
 261     serverPrivateGargAPI _                     = throwAll' (_ServerError # err401)
 262 -- Here throwAll' requires a concrete type for the monad.
 263
 264
 265 -- TODO-SECURITY admin only: withAdmin
 266 -- Question: How do we mark admins?
 267 {-
 268 serverGargAdminAPI :: GargServer GargAdminAPI
 269 serverGargAdminAPI =  roots
 270                  :<|> nodesAPI
 271 -}
 272
 273 ---------------------------------------------------------------------
 274 --gargMock :: Server GargAPI
 275 --gargMock = mock apiGarg Proxy
 276 ---------------------------------------------------------------------
 277 makeApp :: EnvC env => env -> Text -> IO Application
 278 makeApp env baseUrl = serveWithContext api cfg <$> server env baseUrl
 279   where
 280     cfg :: Servant.Context AuthContext
 281     cfg = env ^. settings . jwtSettings
 282        :. env ^. settings . cookieSettings
 283     -- :. authCheck env
 284        :. EmptyContext
 285
 286 --appMock :: Application
 287 --appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
 288 ---------------------------------------------------------------------
 289 api :: Proxy API
 290 api  = Proxy
 291
 292 apiGarg :: Proxy GargAPI
 293 apiGarg  = Proxy
 294 ---------------------------------------------------------------------
 295 schemaUiServer :: (Server api ~ Handler Swagger)
 296         => Swagger -> Server (SwaggerSchemaUI' dir api)
 297 schemaUiServer = swaggerSchemaUIServer
 298
 299 ---------------------------------------------------------------------
 300 -- Type Family for the Documentation
 301 type family TypeName (x :: *) :: Symbol where
 302     TypeName Int  = "Int"
 303     TypeName Text = "Text"
 304     TypeName x    = GenericTypeName x (Rep x ())
 305
 306 type family GenericTypeName t (r :: *) :: Symbol where
 307     GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
 308
 309 type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
 310
 311