[CORS] Adding CORS for test with frontend/Purescript.

package.yaml

@@ -76,11 +76,20 @@ library:
   - directory
   - duckling
   - filepath
+  - fclabels
+  - fast-logger
+    #  - haskell-gi-base
   - http-conduit
+  - http-api-data
+  - http-types
   - hxt
   - ini
+  - jose-jwt
   - lens
   - logging-effect
+  - monad-logger
+  - mtl
+  - natural-transformation
   - opaleye
   - parsec
   - path
@@ -92,6 +101,7 @@ library:
   - protolude
   - pureMD5
   - regex-compat
+  - resourcet
   - safe
   - semigroups
   - servant
@@ -111,10 +121,13 @@ library:
   - time-locale-compat
   - timezone-series
   - transformers
+  - transformers-base
   - unordered-containers
   - uuid
   - vector
   - wai
+  - wai-cors
+  - wai-extra
   - warp
   - yaml
   - zip

src/Gargantext/API.hs

@@ -70,6 +70,79 @@ import Gargantext.API.Count ( CountAPI, count, Query)
 import Gargantext.Database.Utils (databaseParameters)
 
 ---------------------------------------------------------------------
+
+
+import GHC.Base (Applicative)
+-- import Control.Lens
+
+import Data.List (lookup)
+import Data.Text.Encoding (encodeUtf8)
+
+--import Network.Wai (Request, requestHeaders, responseLBS)
+import Network.Wai (Request, requestHeaders)
+--import qualified Network.Wai.Handler.Warp as Warp
+import Network.Wai.Middleware.Cors
+
+-- import Network.Wai.Middleware.RequestLogger
+-- import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
+
+import Network.HTTP.Types hiding (Query)
+
+
+-- import Gargantext.API.Settings
+
+fireWall :: Applicative f => Request -> f Bool
+fireWall req = do
+    let origin = lookup "Origin" (requestHeaders req)
+    let host   = lookup "Host"   (requestHeaders req)
+
+    let hostOk   = Just (encodeUtf8 "localhost:3000")
+    let originOk = Just (encodeUtf8 "http://localhost:8008")
+
+    if origin == originOk && host == hostOk
+       then pure True
+       else pure False
+
+
+-- makeApp :: Env -> IO (Warp.Settings, Application)
+makeApp :: IO Application
+makeApp = do
+    let serverApp = appMock
+
+    -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
+
+    let checkOriginAndHost app req resp = do
+            blocking <- fireWall req
+            case blocking  of
+                True  -> app req resp
+                False -> app req resp
+                -- False -> resp ( responseLBS status401 [] "Invalid Origin or Host header" )
+        
+    let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
+--            { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
+            { corsOrigins        = Just (["http://localhost:8008"], False)
+            , corsMethods        = [methodGet, methodPost, methodPut, methodDelete]
+            , corsRequestHeaders = ["authorization", "content-type"]
+            , corsExposedHeaders = Nothing
+            , corsMaxAge         = Just ( 60*60*24 ) -- one day
+            , corsVaryOrigin     = False
+            , corsRequireOrigin  = True
+            , corsIgnoreFailures = False
+            }
+
+    --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
+    --          $ Warp.defaultSettings
+    
+    --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
+    pure $ checkOriginAndHost $ corsMiddleware $ serverApp
+
+
+
+
+
+
+
+
 ---------------------------------------------------------------------
 type PortNumber = Int
 ---------------------------------------------------------------------
@@ -194,5 +267,13 @@ startGargantext port file = do
 startGargantextMock :: PortNumber -> IO ()
 startGargantextMock port = do
   portRouteInfo port
-  run port appMock
+
+  application <-makeApp
+
+  run port application
+
+
+
+
+
 

src/Gargantext/API/Application.hs

+{-|
+Module      : Gargantext.API.Application
+Description : Application of the API
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+Inspired by : http://blog.wuzzeb.org/full-stack-web-haskell/server.html
+
+-}
+
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+{-# LANGUAGE OverloadedStrings           #-}
+
+module Gargantext.API.Application
+    where
+
+
+

src/Gargantext/API/Settings.hs

+{-|
+Module      : Gargantext.API.Settings
+Description : Settings of the API (Server and Client)
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
+
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+{-# LANGUAGE DataKinds                   #-}
+{-# LANGUAGE DeriveGeneric               #-}
+{-# LANGUAGE ScopedTypeVariables         #-}
+{-# LANGUAGE TemplateHaskell             #-}
+{-# LANGUAGE OverloadedStrings           #-}
+{-# LANGUAGE FlexibleInstances           #-}
+
+module Gargantext.API.Settings
+    where
+
+import System.Log.FastLogger
+import GHC.Enum
+import GHC.Generics (Generic)
+import Prelude (Bounded())
+import System.Environment (lookupEnv)
+
+-- import Control.Applicative ((<*>))
+
+import Data.Maybe (fromMaybe)
+import Data.Either (either)
+-- import Data.Map
+import Data.Text
+import Data.Text.Encoding (encodeUtf8)
+import Data.ByteString.Lazy.Internal
+
+import Servant
+import Web.HttpApiData (parseUrlPiece)
+import qualified Jose.Jwk as Jose
+import qualified Jose.Jwa as Jose
+
+import Control.Monad.Logger
+import Control.Lens
+import Gargantext.Prelude
+
+
+data SendEmailType = SendEmailViaAws
+                   | LogEmailToConsole
+                   | WriteEmailToFile
+    deriving (Show, Read, Enum, Bounded, Generic)
+
+
+data Settings = Settings
+    { _allowedOrigin   :: ByteString -- ^ allowed origin for CORS
+    , _allowedHost     :: ByteString   -- ^ allowed host for CORS
+    , _appPort         :: Int
+    , _logLevelLimit   :: LogLevel -- ^ log level from the monad-logger package
+    , _dbServer        :: Text
+    , _jwtSecret       :: Jose.Jwk -- ^ key from the jose-jwt package
+    , _sendLoginEmails :: SendEmailType
+    }
+
+makeLenses ''Settings
+
+
+parseJwk :: Text -> Jose.Jwk
+parseJwk secretStr = jwk
+    where
+        secretBs = encodeUtf8 secretStr
+        jwk      = Jose.SymmetricJwk secretBs 
+                                     Nothing 
+                                     Nothing 
+                                     (Just $ Jose.Signed Jose.HS256)
+
+devSettings :: Settings
+devSettings = Settings
+    { _allowedOrigin = "http://localhost:8008"
+    , _allowedHost = "localhost:3000"
+    , _appPort = 3000
+    , _logLevelLimit = LevelDebug
+    , _dbServer = "localhost"
+    -- generate with dd if=/dev/urandom bs=1 count=32 | base64
+    -- make sure jwtSecret differs between development and production, because you do not want
+    -- your production key inside source control.
+    , _jwtSecret = parseJwk "MVg0YAPVSPiYQc/qIs/rV/X32EFR0zOJWfHFgMbszMw="
+    , _sendLoginEmails = LogEmailToConsole
+    }
+
+
+
+reqSetting :: FromHttpApiData a => Text -> IO a
+reqSetting name = do
+    e <- fromMaybe (panic $ "Missing " <> name) <$> lookupEnv (unpack name)
+    pure $ either (panic $ "Unable to parse " <> name) identity $ parseUrlPiece $ pack e
+
+optSetting :: FromHttpApiData a => Text -> a -> IO a
+optSetting name d = do
+    me <- lookupEnv (unpack name)
+    case me of
+        Nothing -> pure d
+        Just e -> pure $ either (panic $ "Unable to parse " <> name) identity $ parseUrlPiece $ pack e
+
+--settingsFromEnvironment :: IO Settings
+--settingsFromEnvironment =
+--    Settings <$> (encodeUtf8 <$> reqSetting "ALLOWED_ORIGIN")
+--             <*> (encodeUtf8 <$> reqSetting "ALLOWED_HOST")
+--             <*> optSetting "PORT" 3000
+--             <*> (parseLogLevel <$> optSetting "LOG_LEVEL" "warn")
+--             <*> reqSetting "DB_SERVER"
+--             <*> (parseJwk <$> reqSetting "JWT_SECRET")
+--             <*> optSetting "SEND_EMAIL" SendEmailViaAws
+
+
+
+data Env = Env
+    { _settings :: Settings
+    , _logger   :: LoggerSet
+    -- , _dbConfig :: ConnectionPool -- from Database.Persist.Postgresql
+    }
+
+makeLenses ''Env
+createEnv :: Settings -> IO Env
+createEnv _ = undefined {- implementation here: connect to db, init logger, etc -}

src/Gargantext/Prelude.hs

@@ -25,6 +25,7 @@ import Protolude ( Bool(True, False), Int, Double, Integer
                  , takeWhile, sqrt, undefined, identity
                  , abs, maximum, minimum, return, snd, truncate
                  , (+), (*), (/), (-), (.), (>=), ($), (**), (^), (<), (>), (==), (<>)
+                 , (&&), (||)
                  , toS
                  )