diff --git a/scion-browser.cabal b/scion-browser.cabal --- a/scion-browser.cabal +++ b/scion-browser.cabal @@ -1,5 +1,5 @@ name: scion-browser -version: 0.4.3 +version: 0.5.0 cabal-version: >= 1.8 build-type: Simple license: BSD3 @@ -33,7 +33,7 @@ aeson >=0.4 && <0.9, parallel-io >= 0.3, utf8-string, - persistent >= 1.2 && < 2, + persistent >= 2.1 && < 3, persistent-sqlite >= 1.2, persistent-template >= 1.2, conduit>=1.0, @@ -114,7 +114,7 @@ aeson >=0.4 && <0.9, parallel-io >= 0.3, utf8-string, - persistent >= 1.2 && <2, + persistent >= 2.1 && < 3, persistent-sqlite >= 1.2, persistent-template >= 1.2, conduit>=1.0, diff --git a/src/Scion/PersistentBrowser/Build.hs b/src/Scion/PersistentBrowser/Build.hs --- a/src/Scion/PersistentBrowser/Build.hs +++ b/src/Scion/PersistentBrowser/Build.hs @@ -83,12 +83,16 @@ -- Parse Hoogle database createDirectoryIfMissing True hoogleDbDir logToStdout "Started downloading Hoogle database" - hoogleDownloaded <- downloadFileLazy hoogleDbUrl - logToStdout "Uncompressing Hoogle database" - unTarGzip hoogleDownloaded hoogleDbDir - logToStdout $ "Hoogle database is now in " ++ hoogleDbDir - createDirectoryIfMissing True tmpDir - (pkgs, errors) <- parseDirectory hoogleDbDir tmpDir + mhoogleDownloaded <- downloadFileLazy hoogleDbUrl + case mhoogleDownloaded of + Just hoogleDownloaded -> do + logToStdout "Uncompressing Hoogle database" + unTarGzip hoogleDownloaded hoogleDbDir + logToStdout $ "Hoogle database is now in " ++ hoogleDbDir + createDirectoryIfMissing True tmpDir + (pkgs, errors) <- parseDirectory hoogleDbDir tmpDir + return (pkgs, errors) + Nothing -> return ([],[]) --let (pkgs, errors) = ([], []) {- -- Parse base package @@ -105,7 +109,7 @@ Left e -> (dbBase, ("ghc.txt", e):errorsBase) return (pkgListToDb dbGhc, errorsGhc) -} - return (pkgs, errors) + -- | Run SQL on the given path runSQL :: FilePath -> SQL a -> IO a diff --git a/src/Scion/PersistentBrowser/DbTypes.hs b/src/Scion/PersistentBrowser/DbTypes.hs --- a/src/Scion/PersistentBrowser/DbTypes.hs +++ b/src/Scion/PersistentBrowser/DbTypes.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls, FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls, FlexibleInstances, MultiParamTypeClasses #-} module Scion.PersistentBrowser.DbTypes where diff --git a/src/Scion/PersistentBrowser/FileUtil.hs b/src/Scion/PersistentBrowser/FileUtil.hs --- a/src/Scion/PersistentBrowser/FileUtil.hs +++ b/src/Scion/PersistentBrowser/FileUtil.hs @@ -5,7 +5,7 @@ import Control.Applicative import qualified Codec.Archive.Tar as Tar import qualified Codec.Compression.GZip as GZip -import Control.Exception (bracket) +import Control.Exception (bracket,catch,SomeException) import qualified Data.ByteString as SBS import qualified Data.ByteString.Lazy as LBS import System.Directory @@ -19,12 +19,15 @@ filterDots = filter (\d -> d /= "." && d /= "..") -- |Downloads a file from the internet. -downloadFileLazy :: String -> IO LBS.ByteString -downloadFileLazy = simpleHttp +downloadFileLazy :: String -> IO (Maybe LBS.ByteString) +downloadFileLazy s = (Just <$> (simpleHttp s)) + -- yes it's bad practice to catch them all, but I don't know what could be thrown here + -- StatusCodeException, yes, and maybe ASN1 exceptions, and probably others... + `catch` \(_ :: SomeException)->return Nothing -- |Downloads a file from the internet. -downloadFileStrict :: String -> IO SBS.ByteString -downloadFileStrict = (LBS.toStrict <$>) . downloadFileLazy +downloadFileStrict :: String -> IO (Maybe SBS.ByteString) +downloadFileStrict = (fmap LBS.toStrict <$>) . downloadFileLazy -- |Downloads a file from the internet and check it's a Hoogle file. @@ -32,6 +35,9 @@ downloadHoogleFile mgr url = do req <- parseUrl url getHoogleFile <$> LBS.toStrict <$> responseBody <$> httpLbs req mgr + -- yes it's bad practice to catch them all, but I don't know what could be thrown here + -- StatusCodeException, yes, and maybe ASN1 exceptions, and probably others... + `catch` \(_ :: SomeException)->return Nothing diff --git a/src/Scion/PersistentBrowser/Query.hs b/src/Scion/PersistentBrowser/Query.hs --- a/src/Scion/PersistentBrowser/Query.hs +++ b/src/Scion/PersistentBrowser/Query.hs @@ -68,7 +68,7 @@ queryDb sql [modName ++ ".%", pkgName, pkgVersion] moduleAction moduleAction :: [PersistValue] -> DbModule -moduleAction [PersistText name, doc, pkgId@(PersistInt64 _)] = DbModule (T.unpack name) (fromDbText doc) (Key pkgId) +moduleAction [PersistText name, doc, PersistInt64 pkgId] = DbModule (T.unpack name) (fromDbText doc) (DbPackageKey $ SqlBackendKey pkgId) moduleAction _ = error "This should not happen" -- |Get information about all declaration with that name. @@ -88,10 +88,10 @@ queryDb sql [name, pkgName, pkgVersion] declAction declAction :: [PersistValue] -> DbDecl -declAction [PersistText declType, PersistText name , doc, kind, signature, equals, modId@(PersistInt64 _)] = +declAction [PersistText declType, PersistText name , doc, kind, signature, equals, PersistInt64 modId] = DbDecl (read (T.unpack declType)) (T.unpack name) (fromDbText doc) (fromDbText kind) (fromDbText signature) (fromDbText equals) - (Key modId) + (DbModuleKey $ SqlBackendKey modId) declAction _ = error "This should not happen" @@ -131,13 +131,13 @@ dclAll <- getAllDeclInfo (dclId, dcl) return (p, dclAll)) elts where action :: [PersistValue] -> (DbDeclId, DbDecl, DbPackageIdentifier) - action [declId@(PersistInt64 _), PersistText declType, PersistText name - , doc, kind, signature, equals, modId@(PersistInt64 _) + action [PersistInt64 declId, PersistText declType, PersistText name + , doc, kind, signature, equals, PersistInt64 modId , PersistText pkgName, PersistText pkgVersion] = - ( Key declId + ( DbDeclKey $ SqlBackendKey declId , DbDecl (read (T.unpack declType)) (T.unpack name) (fromDbText doc) (fromDbText kind) (fromDbText signature) (fromDbText equals) - (Key modId) + (DbModuleKey $ SqlBackendKey modId) , DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion) ) action _ = error "This should not happen" @@ -167,15 +167,15 @@ let dclAll=DbCompleteDecl dcl [] [] [] cs return (p,m, dclAll)) elts where action :: [PersistValue] -> (DbDeclId, DbDecl, DbPackageIdentifier, DbModule) - action [declId@(PersistInt64 _), PersistText declType, PersistText name - , doc, kind, signature, equals, modId@(PersistInt64 _) + action [ PersistInt64 declId, PersistText declType, PersistText name + , doc, kind, signature, equals, PersistInt64 modId , PersistText modName, PersistText pkgName, PersistText pkgVersion] = - ( Key declId + ( DbDeclKey $ SqlBackendKey declId , DbDecl (read (T.unpack declType)) (T.unpack name) (fromDbText doc) (fromDbText kind) (fromDbText signature) (fromDbText equals) - (Key modId) + (DbModuleKey $ SqlBackendKey modId) , DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion) - , DbModule (T.unpack modName) Nothing (Key modId) + , DbModule (T.unpack modName) Nothing (DbPackageKey $ SqlBackendKey modId) ) action _ = error "This should not happen" consts declId=do @@ -214,7 +214,7 @@ cons <- queryDb sqlCons [declName] action return (decls ++ cons) where action :: [PersistValue] -> (DbModule,String,String) - action [PersistText name, doc, pkgId@(PersistInt64 _),PersistText decl,PersistText pkgName] = (DbModule (T.unpack name) (fromDbText doc) (Key pkgId),T.unpack decl,T.unpack pkgName) + action [PersistText name, doc, PersistInt64 pkgId,PersistText decl,PersistText pkgName] = (DbModule (T.unpack name) (fromDbText doc) (DbPackageKey $ SqlBackendKey pkgId),T.unpack decl,T.unpack pkgName) action _ = error "This should not happen" -- |Executes a query. diff --git a/src/Scion/PersistentBrowser/ToDb.hs b/src/Scion/PersistentBrowser/ToDb.hs --- a/src/Scion/PersistentBrowser/ToDb.hs +++ b/src/Scion/PersistentBrowser/ToDb.hs @@ -1,11 +1,14 @@ -{-# LANGUAGE RankNTypes, KindSignatures, CPP #-} +{-# LANGUAGE RankNTypes, KindSignatures, CPP, FunctionalDependencies, TypeFamilies #-} module Scion.PersistentBrowser.ToDb where +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader import Data.Maybe (maybeToList) import qualified Data.Map as M import qualified Data.Text as T import Data.Version (showVersion) import Database.Persist +import Database.Persist.Sql import Distribution.Package hiding (Package) import Language.Haskell.Exts.Annotated.Syntax hiding (String) import Language.Haskell.Exts.Pretty @@ -16,32 +19,27 @@ -- SAVING IN THE DATABASE -- ====================== --- savePackageToDb :: PersistBackend backend m => Documented Package -> backend m () savePackageToDb :: forall (m :: * -> *). - PersistStore m => - Package Doc -> m () + MonadIO m => + Package Doc + -> ReaderT + SqlBackend m () savePackageToDb (Package doc (PackageIdentifier (PackageName name) version) modules) = do pkgId <- insert $ DbPackage name (showVersion version) (docToString doc) mapM_ (saveModuleToDb pkgId) (M.elems modules) --- saveModuleToDb :: PersistBackend backend m => DbPackageId -> Documented Module -> backend m () saveModuleToDb :: forall (m :: * -> *). - PersistStore m => - KeyBackend - (PersistMonadBackend m) (DbPackageGeneric (PersistMonadBackend m)) - -> Module Doc -> m () + MonadIO m => + Key DbPackage -> Module Doc -> ReaderT SqlBackend m () saveModuleToDb pkgId (Module doc (Just (ModuleHead _ (ModuleName _ name)_ _)) _ _ decls) = do moduleId <- insert $ DbModule name (docToString doc) pkgId mapM_ (saveDeclToDb moduleId) decls saveModuleToDb _ m = error $ "saveModuleToDb: This should never happen" ++ (show m) --- saveDeclToDb :: PersistBackend backend m => DbModuleId -> Documented Decl -> backend m () --- Datatypes + saveDeclToDb :: forall (m :: * -> *). - PersistStore m => - KeyBackend - (PersistMonadBackend m) (DbModuleGeneric (PersistMonadBackend m)) - -> Decl Doc -> m () + MonadIO m => + Key DbModule -> Decl Doc -> ReaderT SqlBackend m () saveDeclToDb moduleId (GDataDecl doc (DataType _) ctx hd kind decls _) = do let (declName, declVars) = declHeadToDb hd declId <- insert $ DbDecl DbData declName (docToString doc) @@ -94,32 +92,27 @@ saveDeclToDb _ t = error $ "saveDeclToDb: This should never happen" ++ (show t) saveTyVarToDb :: forall (m :: * -> *). - PersistStore m => - KeyBackend - (PersistMonadBackend m) (DbDeclGeneric (PersistMonadBackend m)) - -> String -> m (Key (DbTyVarGeneric (PersistMonadBackend m))) + MonadIO m => + Key DbDecl -> String -> ReaderT SqlBackend m (Key DbTyVar) saveTyVarToDb declId var = insert $ DbTyVar var declId + saveFunDepToDb :: forall (m :: * -> *). - PersistStore m => - KeyBackend - (PersistMonadBackend m) (DbDeclGeneric (PersistMonadBackend m)) - -> String -> m (Key (DbTyVarGeneric (PersistMonadBackend m))) + MonadIO m => + Key DbDecl -> String -> ReaderT SqlBackend m (Key DbTyVar) saveFunDepToDb declId var = insert $ DbTyVar var declId + saveContextToDb :: forall (m :: * -> *). - PersistStore m => - KeyBackend - (PersistMonadBackend m) (DbDeclGeneric (PersistMonadBackend m)) - -> String -> m (Key (DbContextGeneric (PersistMonadBackend m))) + MonadIO m => + Key DbDecl -> String -> ReaderT SqlBackend m (Key DbContext) saveContextToDb declId ctx = insert $ DbContext ctx declId + saveConstructorToDb :: forall (m :: * -> *) l. - (SrcInfo l, PersistStore m) => - KeyBackend - (PersistMonadBackend m) (DbDeclGeneric (PersistMonadBackend m)) - -> GadtDecl l - -> m (Key (DbConstructorGeneric (PersistMonadBackend m))) + (SrcInfo l, MonadIO m) => + Key DbDecl + -> GadtDecl l -> ReaderT SqlBackend m (Key DbConstructor) #if MIN_VERSION_haskell_src_exts(1,16,0) saveConstructorToDb declId (GadtDecl _ name _ ty) = insert $ DbConstructor (getNameString name) (singleLinePrettyPrint ty) declId #else @@ -129,38 +122,32 @@ -- ============================ deletePackageByInfo :: forall (m :: * -> *). - PersistQuery m => - PackageIdentifier -> m () + MonadIO m => + PackageIdentifier -> ReaderT SqlBackend m () deletePackageByInfo (PackageIdentifier (PackageName name) version) = do Just pkg <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. showVersion version ] [] let pkgId = entityKey pkg deletePackage pkgId deletePackage :: forall (m :: * -> *). - PersistQuery m => - KeyBackend - (PersistMonadBackend m) (DbPackageGeneric (PersistMonadBackend m)) - -> m () + MonadIO m => + Key DbPackage -> ReaderT SqlBackend m () deletePackage pkgId = do modules <- selectList [ DbModulePackageId ==. pkgId ] [] mapM_ (deleteModule . entityKey) modules delete pkgId deleteModule :: forall (m :: * -> *). - PersistQuery m => - KeyBackend - (PersistMonadBackend m) (DbModuleGeneric (PersistMonadBackend m)) - -> m () + MonadIO m => + Key DbModule -> ReaderT SqlBackend m () deleteModule moduleId = do decls <- selectList [ DbDeclModuleId ==. moduleId ] [] mapM_ (deleteDecl . entityKey) decls delete moduleId deleteDecl :: forall (m :: * -> *). - PersistQuery m => - KeyBackend - (PersistMonadBackend m) (DbDeclGeneric (PersistMonadBackend m)) - -> m () + MonadIO m => + Key DbDecl -> ReaderT SqlBackend m () deleteDecl declId = do deleteWhere [ DbTyVarDeclId ==. declId ] deleteWhere [ DbFunDepDeclId ==. declId ] diff --git a/src/Scion/PersistentHoogle/Parser.hs b/src/Scion/PersistentHoogle/Parser.hs --- a/src/Scion/PersistentHoogle/Parser.hs +++ b/src/Scion/PersistentHoogle/Parser.hs @@ -5,6 +5,7 @@ import Data.List (intercalate) import qualified Data.Text as T import Database.Persist +import Database.Persist.Sql import Language.Haskell.Exts.Annotated.Syntax import Scion.PersistentBrowser.DbTypes import Scion.PersistentBrowser.Parser.Internal @@ -112,9 +113,9 @@ ++ " AND DbModule.name = ?" mods <- queryDb sql [mname] action return $ if null mods then Nothing else Just (RModule mods) - where action [PersistText modName, modDoc, pkgId@(PersistInt64 _), PersistText pkgName, PersistText pkgVersion] = + where action [PersistText modName, modDoc, PersistInt64 pkgId, PersistText pkgName, PersistText pkgVersion] = ( DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion) - , DbModule (T.unpack modName) (fromDbText modDoc) (Key pkgId) ) + , DbModule (T.unpack modName) (fromDbText modDoc) (DbPackageKey $ SqlBackendKey pkgId) ) action _ = error "This should not happen" convertHalfToResult (HalfDecl mname dcl) = do let sql = "SELECT DbDecl.id, DbDecl.declType, DbDecl.name, DbDecl.doc, DbDecl.kind, DbDecl.signature, DbDecl.equals, DbDecl.moduleId" @@ -128,13 +129,13 @@ completeDecls <- mapM (\(pkgId, modName, dclKey, dclInfo) -> do complete <- getAllDeclInfo (dclKey, dclInfo) return (pkgId, modName, complete) ) decls return $ if null completeDecls then Nothing else Just (RDeclaration completeDecls) - where action [ declId@(PersistInt64 _), PersistText declType, PersistText declName - , declDoc, declKind, declSignature, declEquals, modId@(PersistInt64 _) + where action [ PersistInt64 declId, PersistText declType, PersistText declName + , declDoc, declKind, declSignature, declEquals, PersistInt64 modId , PersistText pkgName, PersistText pkgVersion ] = - let (innerDclKey :: DbDeclId) = Key declId + let (innerDclKey :: DbDeclId) = DbDeclKey $ SqlBackendKey declId innerDcl = DbDecl (read (T.unpack declType)) (T.unpack declName) (fromDbText declDoc) (fromDbText declKind) (fromDbText declSignature) (fromDbText declEquals) - (Key modId) + (DbModuleKey $ SqlBackendKey modId) in ( DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion) , mname , innerDclKey @@ -156,18 +157,18 @@ return (pkgId, modName, complete, cst) ) decls return $ if null completeDecls then Nothing else Just (RConstructor completeDecls) where action [ PersistText constName, PersistText constSignature - , declId@(PersistInt64 _), PersistText declType, PersistText declName - , declDoc, declKind, declSignature, declEquals, modId@(PersistInt64 _) + , PersistInt64 declId, PersistText declType, PersistText declName + , declDoc, declKind, declSignature, declEquals, PersistInt64 modId , PersistText pkgName, PersistText pkgVersion ] = - let (innerDclKey :: DbDeclId) = Key declId + let (innerDclKey :: DbDeclId) = DbDeclKey $ SqlBackendKey declId innerDcl = DbDecl (read (T.unpack declType)) (T.unpack declName) (fromDbText declDoc) (fromDbText declKind) (fromDbText declSignature) (fromDbText declEquals) - (Key modId) + (DbModuleKey $ SqlBackendKey modId) in ( DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion) , mname , innerDclKey , innerDcl - , DbConstructor (T.unpack constName) (T.unpack constSignature) (Key declId) + , DbConstructor (T.unpack constName) (T.unpack constSignature) (DbDeclKey $ SqlBackendKey declId) ) action _ = error "This should not happen"