70a4737..master · project-m36

git.iko.soy/project-m36

on master help sign in

.github/workflows/ci.yaml+9−7

since splitsnapshots

unifiedsplit

@@ -18,6 +18,7 @@ jobs:

18 - name: docker load

19 run: docker load < $(nix-build docker.nix)

20 - name: docker login

21+ if: ${{ github.ref == 'refs/heads/master' }}

21 run: echo ${{secrets.DOCKERHUB_PASSWORD}} | docker login --username ${{secrets.DOCKERHUB_USER}} --password-stdin

22 run: echo ${{secrets.DOCKERHUB_PASSWORD}} | docker login --username ${{secrets.DOCKERHUB_USER}} --password-stdin

22 - name: docker tag with version

23 - name: docker tag with version

23 run: docker tag project-m36:latest projectm36/project-m36:$(awk '/^Version:/ {print $2}' project-m36.cabal)

24 run: docker tag project-m36:latest projectm36/project-m36:$(awk '/^Version:/ {print $2}' project-m36.cabal)

@@ -40,23 +41,24 @@ jobs:

40 include:

41 include:

41 - os: macos-latest

42 - os: macos-latest

42 ghc: ghc8.10

43 ghc: ghc8.10

44+ env:

45+ STACK_YAML: stack.${{ matrix.ghc }}.yaml

43 steps:

46 steps:

44− - name: Setup

45− run: |

46− echo "::set-env name=stack-yaml::stack.${{ matrix.ghc }}.yaml"

47 - uses: actions/checkout@v2

48 - name: Cache

49 uses: actions/cache@v1

50 with:

51 path: ~/.stack

52− key: ${{ runner.os }}-build-stack-${{ env.stack-yaml }}-${{ hashFiles(env.stack-yaml) }}-${{ hashFiles('**/*.cabal') }}

52+ key: ${{ runner.os }}-build-stack-${{ matrix.ghc }}-${{ hashFiles(env.STACK_YAML) }}-${{ hashFiles('**/*.cabal') }}

53 restore-keys: |

54− ${{ runner.os }}-build-stack-${{ env.stack-yaml }}-${{ hashFiles(env.stack-yaml) }}

54+ ${{ runner.os }}-build-stack-${{ matrix.ghc }}-${{ hashFiles(env.STACK_YAML) }}

55− ${{ runner.os }}-build-stack-${{ env.stack-yaml }}

55+ ${{ runner.os }}-build-stack-${{ matrix.ghc }}

56+ - name: Fix macOS cache bug

57+ run: rm -rf ~/.stack/setup-exe-cache

56 - name: Build

58 - name: Build

57 run: stack build --ghc-options -O2 --local-bin-path out --copy-bins

59 run: stack build --ghc-options -O2 --local-bin-path out --copy-bins

58 - name: Test

60 - name: Test

59− run: stack test --stack-yaml=${{ env.stack-yaml }}

61+ run: stack test --stack-yaml=${{ env.STACK_YAML }}

60 - name: HLint

62 - name: HLint

61 run: curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s .

63 run: curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s .

62 - name: Haddock

64 - name: Haddock

README.markdown−1

@@ -4,7 +4,6 @@

4[![Public Domain](https://img.shields.io/badge/license-Public%20Domain-brightgreen.svg)](http://unlicense.org)

5[![Hackage](https://img.shields.io/hackage/v/project-m36.svg)](http://hackage.haskell.org/package/project-m36)

6[![Hackage dependency status](https://img.shields.io/hackage-deps/v/project-m36.svg)](http://packdeps.haskellers.com/feed?needle=project-m36)

7−[![Build status](https://travis-ci.org/agentm/project-m36.svg?branch=master)](https://travis-ci.org/agentm/project-m36)

8[![Windows Build status](https://ci.appveyor.com/api/projects/status/q7jyddd6dy1ibqdo/branch/master?svg=true)](https://ci.appveyor.com/project/agentm/project-m36)

7[![Windows Build status](https://ci.appveyor.com/api/projects/status/q7jyddd6dy1ibqdo/branch/master?svg=true)](https://ci.appveyor.com/project/agentm/project-m36)

9[![Github Workflow status](https://github.com/agentm/project-m36/workflows/CI/badge.svg)](https://github.com/agentm/project-m36/actions?query=workflow%3ACI)

8[![Github Workflow status](https://github.com/agentm/project-m36/workflows/CI/badge.svg)](https://github.com/agentm/project-m36/actions?query=workflow%3ACI)

docker.nix+1−1

@@ -4,7 +4,7 @@

4}:

5let

6 release = import ./release.nix { inherit pkgs compiler sources; };

7− static-project-m36 = pkgs.haskell.lib.justStaticExecutables release.project;

7+ static-project-m36 = pkgs.haskell.lib.dontCheck (pkgs.haskell.lib.justStaticExecutables release.project);

8in

9pkgs.dockerTools.buildImage {

10 name = "project-m36";

docs/introduction_to_the_relational_algebra.markdown+1−1

@@ -202,7 +202,7 @@ Join (Instructor relation)

202

203(Course Relation)

204

205−|(Course Name, Course Name Type)|(Instructor, Instructor Name Type)|(Course Room Number, Room Number Type)|

205+|(Course Name, Course Name Type)|(Instructor Name, Instructor Name Type)|(Course Room Number, Room Number Type)|

206|-------------------------------|----------------------------------|--------------------------------------|

207|English 1|Steve|Room 104|

208|French 2|Bob|Room 103|

project-m36.cabal+1−1

@@ -433,7 +433,7 @@ Test-Suite test-scripts

433

434Executable project-m36-websocket-server

435 Default-Language: Haskell2010

436− Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, semigroups, attoparsec, parser-combinators, prettyprinter, network, modern-uri, http-conduit, base16-bytestring, http-types, cryptohash-sha256

436+ Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, semigroups, attoparsec, parser-combinators, prettyprinter, network, modern-uri, http-conduit, base16-bytestring, http-types, cryptohash-sha256, wai, wai-websockets, warp, warp-tls

437 Main-Is: ProjectM36/Server/WebSocket/websocket-server.hs

438 Other-Modules: ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer

439 GHC-Options: -Wall -threaded

src/bin/ProjectM36/Server/WebSocket/websocket-server.hs+42−9

@@ -1,23 +1,40 @@

1{-# LANGUAGE CPP #-}

2−import ProjectM36.Server.WebSocket

3−import ProjectM36.Server.Config

4−import ProjectM36.Server.ParseArgs

5−import ProjectM36.Server

6import Control.Concurrent

3import Control.Concurrent

7−import qualified Network.WebSockets as WS

8import Control.Exception

4import Control.Exception

5+import Control.Monad (when)

6+import Data.Maybe (isJust)

7+import Data.String (fromString)

8+import Network.HTTP.Types (status400)

9import Network.Socket

10+import Network.Wai (Application, responseLBS)

11+import Network.Wai.Handler.Warp

12+import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings)

13+import qualified Network.Wai.Handler.WebSockets as WS

14+import Network.WebSockets (defaultConnectionOptions)

15+import ProjectM36.Server

16+import ProjectM36.Server.Config

17+import ProjectM36.Server.ParseArgs

18+import ProjectM36.Server.WebSocket

11main :: IO ()

20main :: IO ()

12main = do

21main = do

13 -- launch normal project-m36-server

22 -- launch normal project-m36-server

14 addressMVar <- newEmptyMVar

23 addressMVar <- newEmptyMVar

15− serverConfig <- parseConfigWithDefaults (defaultServerConfig { bindPort = 8000, bindHost = "127.0.0.1" })

24+ wsConfig <- parseWSConfigWithDefaults (defaultServerConfig {bindPort = 8000, bindHost = "127.0.0.1"})

25+

16 --usurp the serverConfig for our websocket server and make the proxied server run locally

26 --usurp the serverConfig for our websocket server and make the proxied server run locally

27+ let serverConfig = wsServerConfig wsConfig

17− let wsHost = bindHost serverConfig

28+ wsHost = bindHost serverConfig

18 wsPort = bindPort serverConfig

29 wsPort = bindPort serverConfig

19 serverHost = "127.0.0.1"

30 serverHost = "127.0.0.1"

20 serverConfig' = serverConfig {bindPort = 0, bindHost = serverHost}

31 serverConfig' = serverConfig {bindPort = 0, bindHost = serverHost}

32+ configCertificateFile = tlsCertificatePath wsConfig

33+ configKeyFile = tlsKeyPath wsConfig

34+

35+ when (isJust configCertificateFile /= isJust configKeyFile) $

36+ throwIO $ ErrorCall "TLS_CERTIFICATE_PATH and TLS_KEY_PATH must be set in tandem"

37+

21 _ <- forkFinally (launchServer serverConfig' (Just addressMVar) >> pure ()) (either throwIO pure)

38 _ <- forkFinally (launchServer serverConfig' (Just addressMVar) >> pure ()) (either throwIO pure)

22 --wait for server to be listening

39 --wait for server to be listening

23 addr <- takeMVar addressMVar

40 addr <- takeMVar addressMVar

@@ -25,6 +42,22 @@ main = do

25 case addr of

42 case addr of

26 SockAddrInet port' _ -> fromIntegral port'

43 SockAddrInet port' _ -> fromIntegral port'

27 _ -> error "unsupported socket address (IPv4 only currently)"

44 _ -> error "unsupported socket address (IPv4 only currently)"

28− --this built-in server is apparently not meant for production use, but it's easier to test than starting up the wai or snap interfaces

45+ wsApp = websocketProxyServer port serverHost

46+ waiApp = WS.websocketsOr defaultConnectionOptions wsApp backupApp

29− WS.runServer wsHost (fromIntegral wsPort) (websocketProxyServer port serverHost)

47+ settings = warpSettings wsHost (fromIntegral wsPort)

48+

49+ case (configCertificateFile, configKeyFile) of

50+ (Just certificate, Just key) -> runTLS (tlsSettings certificate key) settings waiApp

51+ _ -> runSettings settings waiApp

52+

53+backupApp :: Application

54+backupApp _ respond = respond $ responseLBS status400 [] "Not a WebSocket request"

56+warpSettings :: HostName -> Port -> Settings

57+warpSettings host port =

58+ setHost (fromString host)

59+ . setPort port

60+ . setServerName "project-m36"

61+ . setTimeout 3600

62+ . setGracefulShutdownTimeout (Just 5)

63+ $ defaultSettings

src/lib/ProjectM36/Server/Config.hs+6

@@ -12,6 +12,12 @@ data ServerConfig = ServerConfig { persistenceStrategy :: PersistenceStrategy,

12 }

13 deriving (Show)

15+data WebsocketServerConfig = WebsocketServerConfig { wsServerConfig :: ServerConfig,

16+ tlsCertificatePath :: Maybe String,

17+ tlsKeyPath :: Maybe String

18+ }

19+ deriving (Show)

20+

15defaultServerConfig :: ServerConfig

21defaultServerConfig :: ServerConfig

16defaultServerConfig = ServerConfig { persistenceStrategy = NoPersistence,

22defaultServerConfig = ServerConfig { persistenceStrategy = NoPersistence,

17 checkFS = True,

23 checkFS = True,

src/lib/ProjectM36/Server/ParseArgs.hs+31−14

@@ -17,14 +17,14 @@ parseArgsWithDefaults defaults = ServerConfig <$>

17 many parseGhcPkgPath <*>

18 parseTimeout (perRequestTimeout defaults) <*>

19 parseTestMode

20−

20+

21parsePersistenceStrategy :: Parser PersistenceStrategy

22parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>

23 MinimalPersistence <$> dbdirOpt <|>

24 pure NoPersistence

25− where

25+ where

26− dbdirOpt = strOption (short 'd' <>

26+ dbdirOpt = strOption (short 'd' <>

27− long "database-directory" <>

27+ long "database-directory" <>

28 metavar "DIRECTORY" <>

29 showDefaultWith show

30 )

@@ -34,43 +34,60 @@ parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>

35parseTestMode :: Parser Bool

36parseTestMode = flag True False (long "test-mode" <> hidden)

37−

37+

38−parseCheckFS :: Parser Bool

38+parseCheckFS :: Parser Bool

39parseCheckFS = flag True False (long "disable-fscheck" <>

40 help "Disable filesystem check for journaling.")

41−

41+

42parseDatabaseName :: Parser DatabaseName

43parseDatabaseName = strOption (short 'n' <>

44 long "database" <>

45 metavar "DATABASE_NAME")

47−parseHostname :: Hostname -> Parser Hostname

47+parseHostname :: Hostname -> Parser Hostname

48parseHostname defHostname = strOption (short 'h' <>

49 long "hostname" <>

50 metavar "HOST_NAME" <>

51 value defHostname)

52−

52+

53parsePort :: Port -> Parser Port

54parsePort defPort = option auto (short 'p' <>

55 long "port" <>

56 metavar "PORT_NUMBER" <>

57 value defPort)

58−

58+

59parseGhcPkgPath :: Parser String

60parseGhcPkgPath = strOption (long "ghc-pkg-dir" <>

61 metavar "GHC_PACKAGE_DIRECTORY")

62−

62+

63−parseTimeout :: Int -> Parser Int

63+parseTimeout :: Int -> Parser Int

64parseTimeout defTimeout = option auto (long "timeout" <>

65 metavar "MICROSECONDS" <>

66 value defTimeout)

68parseConfig :: IO ServerConfig

69parseConfig = parseConfigWithDefaults defaultServerConfig

70−

70+

71parseConfigWithDefaults :: ServerConfig -> IO ServerConfig

72parseConfigWithDefaults defaults = execParser (info (parseArgsWithDefaults defaults <**> helpOption) idm)

74+parseWSConfigWithDefaults :: ServerConfig -> IO WebsocketServerConfig

75+parseWSConfigWithDefaults defaults = execParser (info (parseWSArgsWithDefaults defaults <**> helpOption) idm)

76+

77+parseWSArgsWithDefaults :: ServerConfig -> Parser WebsocketServerConfig

78+parseWSArgsWithDefaults defaults = WebsocketServerConfig <$>

79+ parseArgsWithDefaults defaults <*>

80+ parseTlsCertificatePath <*>

81+ parseTlsKeyPath

82+

83+

84+parseTlsCertificatePath :: Parser (Maybe String)

85+parseTlsCertificatePath = optional $ strOption (long "tls-certificate-path" <>

86+ metavar "TLS_CERTIFICATE_PATH")

87+

88+parseTlsKeyPath :: Parser (Maybe String)

89+parseTlsKeyPath = optional $ strOption (long "tls-key-path" <>

90+ metavar "TLS_KEY_PATH")

75helpOption :: Parser (a -> a)

92helpOption :: Parser (a -> a)

76helpOption = abortOption helpText $ mconcat

93helpOption = abortOption helpText $ mconcat

@@ -80,6 +97,6 @@ helpOption = abortOption helpText $ mconcat

80 where

97 where

81#if MIN_VERSION_optparse_applicative(0,16,0)

98#if MIN_VERSION_optparse_applicative(0,16,0)

82 helpText = ShowHelpText Nothing

99 helpText = ShowHelpText Nothing

83−#else

100+#else

84 helpText = ShowHelpText

101 helpText = ShowHelpText

85#endif

102#endif