scion-browser-0.2.3: src/Server/PersistentCommands.hs
{-# LANGUAGE OverloadedStrings #-}
module Server.PersistentCommands where
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Data.Aeson
import qualified Data.HashMap.Lazy as M
import Data.Maybe (isJust, fromJust)
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
| SetExtraHooglePath 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
, extraHooglePath :: Maybe String
}
initialState :: BrowserState
initialState = BrowserState Nothing Nothing True True Nothing Nothing
runWithState :: BrowserState -> (Maybe DbPackageIdentifier -> SqlPersist IO [a]) -> IO [a]
runWithState (BrowserState lDb hDb useL useH filterPkg _) action =
do localThings <- runWithState' useL lDb (action filterPkg)
hackageThings <- runWithState' useH hDb (action filterPkg)
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 :: (Maybe DbPackageIdentifier -> 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 extraH <- fmap extraHooglePath get
results <- runDb (\_ -> H.query extraH query)
return (toJSON results, True)
executeCommand HoogleDownloadData = do extraH <- fmap extraHooglePath get
_ <- lift $ H.downloadData extraH
return (String "ok", True)
executeCommand HoogleCheckDatabase = do extraH <- fmap extraHooglePath get
present <- lift $ H.checkDatabase extraH
return (Bool present, True)
executeCommand (SetExtraHooglePath p) = do modify (\s -> s { extraHooglePath = Just p })
return (String "ok", 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
"extra-hoogle-path" -> SetExtraHooglePath <$> v .: "path"
"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