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