From 0c5b7d16ed17d527bccdafa6e6ffbccc34a81b8f Mon Sep 17 00:00:00 2001 From: serras Date: Sat, 19 Nov 2011 20:11:25 +0100 Subject: [PATCH] Change main to use the new Persistent layer --- scion-browser.cabal | 15 ++-- src/Main.hs | 17 +--- src/Server/PersistentCommands.hs | 149 +++++++++++++++++++++++++++++++ 3 files changed, 159 insertions(+), 22 deletions(-) create mode 100644 src/Server/PersistentCommands.hs diff --git a/scion-browser.cabal b/scion-browser.cabal index 5d8331b..50e0e17 100644 --- a/scion-browser.cabal +++ b/scion-browser.cabal @@ -61,13 +61,15 @@ library -- For Scion.Packages (provisional) ghc >= 6.10 && < 6.13 - extra-libraries: tinfo + if !os(mingw32) + extra-libraries: tinfo exposed-modules: Scion.PersistentBrowser, Scion.PersistentBrowser.Query, Scion.PersistentBrowser.Build, - Scion.PersistentHoogle + Scion.PersistentHoogle, + Server.PersistentCommands ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -fno-warn-orphans @@ -121,10 +123,10 @@ executable scion-browser -- For Scion.Packages (provisional) ghc >= 6.10 && < 6.13 - extra-libraries: tinfo + if !os(mingw32) + extra-libraries: tinfo ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -fno-warn-orphans -threaded - other-modules: Server.Commands, Scion.Browser.Instances.Json, Scion.Browser.Instances.NFData, Scion.Browser.Instances.Serialize, Scion.Browser.Parser.Documentable, Scion.Browser.Parser.Internal, Scion.Browser.Build, Scion.Browser.FileUtil, Scion.Browser.Parser, Scion.Browser.Query, Scion.Browser.TempFile, Scion.Browser.Types, Scion.Browser.Util, Scion.Hoogle.Instances.Json, Scion.Hoogle.Parser, Scion.Hoogle.Types, Scion.Hoogle.Util, Scion.Browser, Scion.Hoogle, Scion.Packages, Scion.Browser.FromMissingH test-suite BrowserTests main-is: Test.hs @@ -186,5 +188,6 @@ test-suite BrowserTests filepath == 1.1.*, -- For Scion.Packages (provisional) ghc >= 6.10 && < 6.13 - - extra-libraries: tinfo + + if !os(mingw32) + extra-libraries: tinfo diff --git a/src/Main.hs b/src/Main.hs index a13627a..0c1387a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -8,27 +8,12 @@ import qualified Data.Aeson.Types as T import qualified Data.Attoparsec.Char8 as Atto import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS -import Server.Commands +import Server.PersistentCommands import System.Console.Haskeline -import Database.Persist -import Database.Persist.Sqlite -import Scion.PersistentBrowser.DbTypes -import Scion.PersistentBrowser.Build -import Scion.Packages - -{- main :: IO () main = do runStateT (runInputT defaultSettings loop) initialState return () --} - -main :: IO () -main = do withSqliteConn "local.persist" $ runSqlConn $ runMigration migrateAll - pkgInfos' <- getPkgInfos - let pkgInfos = take 20 $ concat $ map snd pkgInfos' - updateDatabase "local.persist" pkgInfos - loop :: InputT BrowserM () loop = do maybeLine <- getInputLine "" diff --git a/src/Server/PersistentCommands.hs b/src/Server/PersistentCommands.hs new file mode 100644 index 0000000..89716a3 --- /dev/null +++ b/src/Server/PersistentCommands.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Server.PersistentCommands where + +import Control.Applicative +import Control.Monad +import Control.Monad.State +import Data.Aeson +import Data.Maybe (isJust, fromJust) +import qualified Data.Map as M +import qualified Data.Text as T +import Database.Persist.Sqlite hiding (get) +import Scion.PersistentBrowser +import Scion.PersistentBrowser.Build +import Scion.PersistentBrowser.Query +import Scion.PersistentBrowser.Util (logToStdout) +import qualified Scion.PersistentHoogle as H +import Scion.Packages +import System.Directory + +data Command = LoadLocalDatabase FilePath Bool + | LoadHackageDatabase FilePath Bool + | GetPackages + | SetCurrentDatabase CurrentDatabase + | GetModules String + | GetDeclarations String + | HoogleQuery String + | HoogleDownloadData + | HoogleCheckDatabase + | GetDeclarationModules String + | Quit + +data CurrentDatabase = AllPackages + | HackageDatabase + | LocalDatabase + | APackage DbPackageIdentifier + +data BrowserState = BrowserState + { localDb :: Maybe FilePath + , hackageDb :: Maybe FilePath + , useLocal :: Bool + , useHackage :: Bool + , filterPackage :: Maybe DbPackageIdentifier + } + +initialState :: BrowserState +initialState = BrowserState Nothing Nothing True True Nothing + +runWithState :: BrowserState -> SqlPersist IO [a] -> IO [a] +runWithState (BrowserState lDb hDb useL useH filterPkg) action = + do localThings <- runWithState' useL lDb action + hackageThings <- runWithState' useH hDb action + return $ localThings ++ hackageThings + +runWithState' :: Bool -> Maybe FilePath -> SqlPersist IO [a] -> IO [a] +runWithState' use mpath action = if use && isJust mpath + then do let path = fromJust mpath + withSqliteConn (T.pack path) $ runSqlConn action + else return [] + +runDb :: SqlPersist IO [a] -> BrowserM [a] +runDb action = do st <- get + lift $ runWithState st action + +type BrowserM = StateT BrowserState IO + +executeCommand :: Command -> BrowserM (Value, Bool) -- Bool indicates if continue receiving commands +executeCommand (LoadLocalDatabase path rebuild) = + do fileExists <- lift $ doesFileExist path + let fileExists' = fileExists `seq` fileExists + when rebuild $ + lift $ do withSqliteConn (T.pack path) $ runSqlConn $ runMigration migrateAll + pkgInfos' <- getPkgInfos + let pkgInfos = concat $ map snd pkgInfos' + updateDatabase path pkgInfos + if fileExists' || rebuild -- If the file already existed or was rebuilt + then do modify (\s -> s { localDb = Just path }) + lift $ logToStdout "Local database loaded" + else modify (\s -> s { hackageDb = Nothing }) + executeCommand (SetCurrentDatabase LocalDatabase) +executeCommand (LoadHackageDatabase path rebuild) = + do fileExists <- lift $ doesFileExist path + let fileExists' = fileExists `seq` fileExists + when (not fileExists' || rebuild) $ + lift $ do when fileExists' (removeFile path) + logToStdout "Rebuilding Hackage database" + withSqliteConn (T.pack path) $ runSqlConn $ runMigration migrateAll + saveHackageDatabase path + if fileExists' || rebuild -- If the file already existed or was rebuilt + then do modify (\s -> s { hackageDb = Just path }) + lift $ logToStdout "Hackage database loaded" + else modify (\s -> s { hackageDb = Nothing }) + executeCommand (SetCurrentDatabase HackageDatabase) +executeCommand (SetCurrentDatabase db) = + do case db of + AllPackages -> do modify (\s -> s { useLocal = True, useHackage = True, filterPackage = Nothing }) + return (String "ok", True) + LocalDatabase -> do modify (\s -> s { useLocal = True, useHackage = False, filterPackage = Nothing }) + return (String "ok", True) + HackageDatabase -> do modify (\s -> s { useLocal = False, useHackage = True, filterPackage = Nothing }) + return (String "ok", True) + APackage pid -> do modify (\s -> s { useLocal = True, useHackage = True, filterPackage = Just pid }) + return (String "ok", True) +executeCommand GetPackages = do pkgs <- runDb allPackages + return (toJSON pkgs, True) +executeCommand (GetModules mname) = do smods <- runDb (getSubmodules mname) + return (toJSON smods, True) +executeCommand (GetDeclarations mname) = do decls <- runDb (getDeclsInModule mname) + return (toJSON decls, True) +executeCommand (HoogleQuery query) = do results <- runDb (H.query query) + return (toJSON results, True) +executeCommand HoogleDownloadData = do _ <- lift $ H.downloadData + return (String "ok", True) +executeCommand HoogleCheckDatabase = do present <- lift $ H.checkDatabase + return (Bool present, True) +executeCommand (GetDeclarationModules d) = do mods <- runDb (getModulesWhereDeclarationIs d) + return (toJSON mods, True) +executeCommand Quit = return (String "ok", False) + + +instance FromJSON Command where + parseJSON (Object v) = case M.lookup (T.pack "command") v of + Just (String e) -> + case T.unpack e of + "load-local-db" -> LoadLocalDatabase <$> v .: "filepath" + <*> v .: "rebuild" + "load-hackage-db" -> LoadHackageDatabase <$> v .: "filepath" + <*> v .: "rebuild" + "get-packages" -> pure GetPackages + "set-current-db" -> SetCurrentDatabase <$> v .: "new-db" + "get-modules" -> GetModules <$> v .: "module" + "get-declarations" -> GetDeclarations <$> v .: "module" + "hoogle-query" -> HoogleQuery <$> v .: "query" + "hoogle-data" -> pure HoogleDownloadData + "hoogle-check" -> pure HoogleCheckDatabase + "get-decl-module" -> GetDeclarationModules <$> v .: "decl" + "quit" -> pure Quit + _ -> mzero + _ -> mzero + parseJSON _ = mzero + +instance FromJSON CurrentDatabase where + parseJSON (String new) = case T.unpack new of + "_all" -> pure AllPackages + "_hackage" -> pure HackageDatabase + "_local" -> pure LocalDatabase + _ -> mzero + parseJSON other = APackage <$> parseJSON other +