@@ -2,41 +2,25 @@
22import TutorialD.Interpreter
33import ProjectM36.Base
44import ProjectM36.Client
5+import ProjectM36.Server.ParseArgs
6+import ProjectM36.Server
57import System.IO
68import Options.Applicative
79import System.Exit
810import Data.Monoid
11+import Data.Maybe
912import qualified Data.Text as T
1013
1114parseArgs :: Parser InterpreterConfig
12−parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseTutDExec <*> parseGhcPkgPaths <|>
13− RemoteInterpreterConfig <$> parseNodeId <*> parseDatabaseName <*> parseHeadName <*> parseTutDExec
15+parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseTutDExec <*> many parseGhcPkgPath <*> parseCheckFS <|>
16+ RemoteInterpreterConfig <$> parseNodeId <*> parseDatabaseName <*> parseHeadName <*> parseTutDExec <*> parseCheckFS
1417
15−parsePersistenceStrategy :: Parser PersistenceStrategy
16−parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>
17− MinimalPersistence <$> dbdirOpt <|>
18− pure NoPersistence
19− where
20− dbdirOpt = strOption (short 'd' <>
21− long "database-directory" <>
22− metavar "DIRECTORY" <>
23− showDefaultWith show
24− )
25− fsyncOpt = switch (short 'f' <>
26− long "fsync" <>
27− help "Fsync all new transactions.")
28−
2918parseHeadName :: Parser HeadName
3019parseHeadName = option auto (long "head" <>
3120 help "Start session at head name." <>
3221 value "master"
3322 )
34−
35−parseDatabaseName :: Parser DatabaseName
36−parseDatabaseName = strOption (long "database" <>
37− short 'n' <>
38− help "Remote database name")
39−
23+
4024parseNodeId :: Parser NodeId
4125parseNodeId = createNodeId <$>
4226 strOption (long "host" <>
@@ -54,31 +38,29 @@ parseTutDExec = optional $ strOption (long "exec-tutd" <>
5438 short 'e' <>
5539 help "Execute TutorialD expression and exit"
5640 )
57−
58−parseGhcPkgPaths :: Parser [GhcPkgPath]
59−parseGhcPkgPaths = many (strOption (long "ghc-pkg-dir" <>
60− metavar "GHC_PACKAGE_DIRECTORY"))
6141
6242opts :: ParserInfo InterpreterConfig
6343opts = info parseArgs idm
6444
6545connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo
66−connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths
67−connectionInfoForConfig (RemoteInterpreterConfig remoteNodeId remoteDBName _ _) = RemoteProcessConnectionInfo remoteDBName remoteNodeId outputNotificationCallback
46+connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths _) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths
47+connectionInfoForConfig (RemoteInterpreterConfig remoteNodeId remoteDBName _ _ _) = RemoteProcessConnectionInfo remoteDBName remoteNodeId outputNotificationCallback
6848
6949headNameForConfig :: InterpreterConfig -> HeadName
70−headNameForConfig (LocalInterpreterConfig _ headn _ _) = headn
71−headNameForConfig (RemoteInterpreterConfig _ _ headn _) = headn
50+headNameForConfig (LocalInterpreterConfig _ headn _ _ _) = headn
51+headNameForConfig (RemoteInterpreterConfig _ _ headn _ _) = headn
7252
7353execTutDForConfig :: InterpreterConfig -> Maybe String
74−execTutDForConfig (LocalInterpreterConfig _ _ t _) = t
75−execTutDForConfig (RemoteInterpreterConfig _ _ _ t) = t
54+execTutDForConfig (LocalInterpreterConfig _ _ t _ _) = t
55+execTutDForConfig (RemoteInterpreterConfig _ _ _ t _) = t
56+
57+checkFSForConfig :: InterpreterConfig -> Bool
58+checkFSForConfig (LocalInterpreterConfig _ _ _ _ c) = c
59+checkFSForConfig (RemoteInterpreterConfig _ _ _ _ c) = c
7660
77−{-
78−ghcPkgPathsForConfig :: InterpreterConfig -> [GhcPkgPath]
79−ghcPkgPathsForConfig (LocalInterpreterConfig _ _ paths) = paths
80−ghcPkgPathsForConfig _ = error "Clients cannot configure remote ghc package paths."
81−-}
61+persistenceStrategyForConfig :: InterpreterConfig -> Maybe PersistenceStrategy
62+persistenceStrategyForConfig (LocalInterpreterConfig strat _ _ _ _) = Just strat
63+persistenceStrategyForConfig RemoteInterpreterConfig{} = Nothing
8264
8365errDie :: String -> IO ()
8466errDie err = hPutStrLn stderr err >> exitFailure
@@ -97,21 +79,25 @@ main :: IO ()
9779main = do
9880 interpreterConfig <- execParser opts
9981 let connInfo = connectionInfoForConfig interpreterConfig
100− dbconn <- connectProjectM36 connInfo
101− case dbconn of
102− Left err ->
103− errDie ("Failed to create database connection: " ++ show err)
104− Right conn -> do
105− let connHeadName = headNameForConfig interpreterConfig
106− eSessionId <- createSessionAtHead conn connHeadName
107− case eSessionId of
108− Left err -> errDie ("Failed to create database session at \"" ++ show connHeadName ++ "\": " ++ show err)
109− Right sessionId ->
110− case execTutDForConfig interpreterConfig of
111− Nothing -> do
112− printWelcome
113− _ <- reprLoop interpreterConfig sessionId conn
114− pure ()
115− Just tutdStr ->
116− runTutorialD sessionId conn (T.pack tutdStr)
82+ fscheck <- checkFSType (checkFSForConfig interpreterConfig) (fromMaybe NoPersistence (persistenceStrategyForConfig interpreterConfig))
83+ if not fscheck then
84+ errDie checkFSErrorMsg
85+ else do
86+ dbconn <- connectProjectM36 connInfo
87+ case dbconn of
88+ Left err ->
89+ errDie ("Failed to create database connection: " ++ show err)
90+ Right conn -> do
91+ let connHeadName = headNameForConfig interpreterConfig
92+ eSessionId <- createSessionAtHead conn connHeadName
93+ case eSessionId of
94+ Left err -> errDie ("Failed to create database session at \"" ++ show connHeadName ++ "\": " ++ show err)
95+ Right sessionId ->
96+ case execTutDForConfig interpreterConfig of
97+ Nothing -> do
98+ printWelcome
99+ _ <- reprLoop interpreterConfig sessionId conn
100+ pure ()
101+ Just tutdStr ->
102+ runTutorialD sessionId conn (T.pack tutdStr)
117103