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