forked from JPMoresmau/scion-class-browser
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Change main to use the new Persistent layer
- Loading branch information
Showing
3 changed files
with
159 additions
and
22 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -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 | ||
|
|