Database.hs

module Stackage.Database
    ( StackageDatabase
    , GetStackageDatabase (..)
    , SnapName (..)
    , Snapshot (..)
    , newestLTS
    , newestLTSMajor
    , ltsMajorVersions
    , newestNightly
    , lookupSnapshot
    , snapshotTitle
    , PackageListingInfo (..)
    , getAllPackages
    , getPackages
    , createStackageDatabase
    , openStackageDatabase
    , ModuleListingInfo (..)
    , getSnapshotModules
    , getPackageModules
    , SnapshotPackage (..)
    , lookupSnapshotPackage
    , getDeprecated
    , LatestInfo (..)
    , getLatests
    , getDeps
    , getRevDeps
    , Package (..)
    , getPackage
    , prettyName
    , getSnapshotsForPackage
    , getSnapshots
    , currentSchema
    , last5Lts5Nightly
    ) where

import Database.Sqlite (SqliteException)
import Web.PathPieces (toPathPiece)
import qualified Codec.Archive.Tar as Tar
import Database.Esqueleto.Internal.Language (From)
import Text.Markdown (Markdown (..))
import System.Directory (removeFile)
import Stackage.Database.Haddock
import System.FilePath (takeBaseName, takeExtension)
import ClassyPrelude.Conduit hiding (pi)
import Text.Blaze.Html (Html, toHtml)
import Yesod.Form.Fields (Textarea (..))
import Stackage.Database.Types
import System.Directory (getAppUserDataDirectory)
import qualified Filesystem as F
import Filesystem.Path (parent)
import Data.Conduit.Process
import Stackage.Types
import Stackage.Metadata
import Stackage.PackageIndex.Conduit
import Web.PathPieces (fromPathPiece)
import Data.Yaml (decodeFileEither)
import Database.Persist
import Database.Persist.Sqlite
import Database.Persist.TH
import Control.Monad.Logger
import System.IO.Temp
import qualified Database.Esqueleto as E
import Data.Yaml (decode)

currentSchema :: Int
currentSchema = 1

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Schema
    val Int
    deriving Show
Imported
    name SnapName
    type Text
    UniqueImported name type

Snapshot
    name SnapName
    ghc Text
    created Day
    UniqueSnapshot name
Lts
    snap SnapshotId
    major Int
    minor Int
    UniqueLts major minor
Nightly
    snap SnapshotId
    day Day
    UniqueNightly day
Package
    name Text
    latest Text
    synopsis Text
    homepage Text
    author Text
    maintainer Text
    licenseName Text
    description Html
    changelog Html
    UniquePackage name
SnapshotPackage
    snapshot SnapshotId
    package PackageId
    isCore Bool
    version Text
    UniqueSnapshotPackage snapshot package
Module
    package SnapshotPackageId
    name Text
    UniqueModule package name
Dep
    user PackageId
    uses Text -- avoid circular dependency issue when loading database
    range Text
    UniqueDep user uses
Deprecated
    package PackageId
    inFavorOf [PackageId]
    UniqueDeprecated package
|]

_hideUnusedWarnings
    :: ( SnapshotPackageId
       , SchemaId
       , ImportedId
       , LtsId
       , NightlyId
       , ModuleId
       , DepId
       , DeprecatedId
       ) -> ()
_hideUnusedWarnings _ = ()

newtype StackageDatabase = StackageDatabase ConnectionPool

class MonadIO m => GetStackageDatabase m where
    getStackageDatabase :: m StackageDatabase
instance MonadIO m => GetStackageDatabase (ReaderT StackageDatabase m) where
    getStackageDatabase = ask

sourcePackages :: MonadResource m => FilePath -> Producer m Tar.Entry
sourcePackages root = do
    dir <- liftIO $ cloneOrUpdate root "commercialhaskell" "all-cabal-metadata"
    bracketP
        (do
            (fp, h) <- openBinaryTempFile "/tmp" "all-cabal-metadata.tar"
            hClose h
            return fp)
        removeFile
        $ \fp -> do
            liftIO $ runIn dir "git" ["archive", "--output", fp, "--format", "tar", "master"]
            sourceTarFile False fp

sourceBuildPlans :: MonadResource m => FilePath -> Producer m (SnapName, FilePath, Either (IO BuildPlan) (IO DocMap))
sourceBuildPlans root = do
    forM_ ["lts-haskell", "stackage-nightly"] $ \repoName -> do
        dir <- liftIO $ cloneOrUpdate root "fpco" repoName
        sourceDirectory dir =$= concatMapMC (go Left)
        let docdir = dir </> "docs"
        whenM (liftIO $ F.isDirectory docdir) $
            sourceDirectory docdir =$= concatMapMC (go Right)
  where
    go wrapper fp | Just name <- nameFromFP fp = liftIO $ do
        let bp = decodeFileEither (fpToString fp) >>= either throwM return
        return $ Just (name, fp, wrapper bp)
    go _ _ = return Nothing

    nameFromFP fp = do
        base <- stripSuffix ".yaml" $ fpToText $ filename fp
        fromPathPiece base

cloneOrUpdate :: FilePath -> String -> String -> IO FilePath
cloneOrUpdate root org name = do
    exists <- F.isDirectory dest
    if exists
        then do
            let git = runIn dest "git"
            git ["fetch"]
            git ["reset", "--hard", "origin/master"]
        else runIn root "git" ["clone", url, name]
    return dest
  where
    url = "https://github.com/" ++ org ++ "/" ++ name ++ ".git"
    dest = root </> fpFromString name

runIn :: FilePath -> String -> [String] -> IO ()
runIn dir cmd args =
    withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return ()
  where
    cp = (proc cmd args) { cwd = Just $ fpToString dir }

openStackageDatabase :: MonadIO m => FilePath -> m StackageDatabase
openStackageDatabase fp = liftIO $ do
    F.createTree $ parent fp
    fmap StackageDatabase $ runNoLoggingT $ createSqlitePool (fpToText fp) 7

getSchema :: FilePath -> IO (Maybe Int)
getSchema fp = do
    StackageDatabase pool <- openStackageDatabase fp
    eres <- try $ runSqlPool (selectList [] []) pool
    putStrLn $ "getSchema result: " ++ tshow eres
    case eres :: Either SqliteException [Entity Schema] of
        Right [Entity _ (Schema v)] -> return $ Just v
        _ -> return Nothing

createStackageDatabase :: MonadIO m => FilePath -> m ()
createStackageDatabase fp = liftIO $ do
    putStrLn "Entering createStackageDatabase"
    actualSchema <- getSchema fp
    let schemaMatch = actualSchema == Just currentSchema
    unless schemaMatch $ do
        putStrLn $ "Current schema does not match actual schema: " ++ tshow (actualSchema, currentSchema)
        putStrLn $ "Deleting " ++ fpToText fp
        void $ tryIO $ removeFile $ fpToString fp

    StackageDatabase pool <- openStackageDatabase fp
    flip runSqlPool pool $ do
        runMigration migrateAll
        unless schemaMatch $ insert_ $ Schema currentSchema

    root <- liftIO $ fmap (</> "database") $ fmap fpFromString $ getAppUserDataDirectory "stackage"
    F.createTree root
    runResourceT $ do
        putStrLn "Updating all-cabal-metadata repo"
        flip runSqlPool pool $ sourcePackages root $$ getZipSink
            ( ZipSink (mapM_C addPackage)
           *> ZipSink (do
                deprs <- foldlC getDeprecated' []
                lift $ do
                    deleteWhere ([] :: [Filter Deprecated])
                    mapM_ addDeprecated deprs)
           *> ZipSink (
                let loop i =
                        await >>= maybe (return ()) (const $ go $ i + 1)
                    go i = do
                        when (i `mod` 500 == 0)
                            $ putStrLn $ concat
                                [ "Processed "
                                , tshow i
                                , " packages"
                                ]
                        loop i
                 in loop (0 :: Int))
            )
        sourceBuildPlans root $$ mapM_C (\(sname, fp', eval) -> flip runSqlPool pool $ do
            let (typ, action) =
                    case eval of
                        Left bp -> ("build-plan", liftIO bp >>= addPlan sname fp')
                        Right dm -> ("doc-map", liftIO dm >>= addDocMap sname)
            let i = Imported sname typ
            eres <- insertBy i
            case eres of
                Left _ -> putStrLn $ "Skipping: " ++ fpToText fp'
                Right _ -> action
            )
        flip runSqlPool pool $ mapM_ (flip rawExecute []) ["COMMIT", "VACUUM", "BEGIN"]

getDeprecated' :: [Deprecation] -> Tar.Entry -> [Deprecation]
getDeprecated' orig e =
    case (Tar.entryPath e, Tar.entryContent e) of
        ("deprecated.yaml", Tar.NormalFile lbs _) ->
            case decode $ toStrict lbs of
                Just x -> x
                Nothing -> orig
        _ -> orig

addDeprecated :: Deprecation -> SqlPersistT (ResourceT IO) ()
addDeprecated (Deprecation name others) = do
    name' <- getPackageId name
    others' <- mapM getPackageId $ setToList others
    insert_ $ Deprecated name' others'

getPackageId :: MonadIO m => Text -> ReaderT SqlBackend m (Key Package)
getPackageId x = do
    keys' <- selectKeysList [PackageName ==. x] [LimitTo 1]
    case keys' of
        k:_ -> return k
        [] -> insert Package
            { packageName = x
            , packageLatest = "unknown"
            , packageSynopsis = "Metadata not found"
            , packageDescription = "Metadata not found"
            , packageChangelog = mempty
            , packageAuthor = ""
            , packageMaintainer = ""
            , packageHomepage = ""
            , packageLicenseName = ""
            }

addPackage :: Tar.Entry -> SqlPersistT (ResourceT IO) ()
addPackage e =
    case ("packages/" `isPrefixOf` fp && takeExtension fp == ".yaml", Tar.entryContent e) of
        (True, Tar.NormalFile lbs _) | Just pi <- decode $ toStrict lbs -> do
            let p = Package
                    { packageName = pack base
                    , packageLatest = display $ piLatest pi
                    , packageSynopsis = piSynopsis pi
                    , packageDescription = renderContent (piDescription pi) (piDescriptionType pi)
                    , packageChangelog = renderContent (piChangeLog pi) (piChangeLogType pi)
                    , packageAuthor = piAuthor pi
                    , packageMaintainer = piMaintainer pi
                    , packageHomepage = piHomepage pi
                    , packageLicenseName = piLicenseName pi
                    }

            mp <- getBy $ UniquePackage $ packageName p
            pid <- case mp of
                Just (Entity pid _) -> do
                    replace pid p
                    return pid
                Nothing -> insert p
            deleteWhere [DepUser ==. pid]
            forM_ (mapToList $ piBasicDeps pi) $ \(uses, range) -> insert_ Dep
                { depUser = pid
                , depUses = display uses
                , depRange = display range
                }
        _ -> return ()
  where
    fp = Tar.entryPath e
    base = takeBaseName fp

    renderContent txt "markdown" = toHtml $ Markdown $ fromStrict txt
    renderContent txt "haddock" = renderHaddock txt
    renderContent txt _ = toHtml $ Textarea txt

addPlan :: SnapName -> FilePath -> BuildPlan -> SqlPersistT (ResourceT IO) ()
addPlan name fp bp = do
    putStrLn $ "Adding build plan: " ++ toPathPiece name
    created <-
        case name of
            SNNightly d -> return d
            SNLts _ _ -> do
                let cp' = proc "git"
                        [ "log"
                        , "--format=%ad"
                        , "--date=short"
                        , fpToString $ filename fp
                        ]
                    cp = cp' { cwd = Just $ fpToString $ directory fp }
                t <- withCheckedProcess cp $ \ClosedStream out ClosedStream ->
                    out $$ decodeUtf8C =$ foldC
                case readMay $ concat $ take 1 $ words t of
                    Just created -> return created
                    Nothing -> do
                        putStrLn $ "Warning: unknown git log output: " ++ tshow t
                        return $ fromGregorian 1970 1 1
    sid <- insert Snapshot
        { snapshotName = name
        , snapshotGhc = display $ siGhcVersion $ bpSystemInfo bp
        , snapshotCreated = created
        }
    forM_ allPackages $ \(display -> pname, (display -> version, isCore)) -> do
        pid <- getPackageId pname
        insert_ SnapshotPackage
            { snapshotPackageSnapshot = sid
            , snapshotPackagePackage = pid
            , snapshotPackageIsCore = isCore
            , snapshotPackageVersion = version
            }
    case name of
        SNLts x y -> insert_ Lts
            { ltsSnap = sid
            , ltsMajor = x
            , ltsMinor = y
            }
        SNNightly d -> insert_ Nightly
            { nightlySnap = sid
            , nightlyDay = d
            }
  where
    allPackages = mapToList
        $ fmap (, True) (siCorePackages $ bpSystemInfo bp)
       ++ fmap ((, False) . ppVersion) (bpPackages bp)

addDocMap :: SnapName -> DocMap -> SqlPersistT (ResourceT IO) ()
addDocMap name dm = do
    [sid] <- selectKeysList [SnapshotName ==. name] []
    putStrLn $ "Adding doc map: " ++ toPathPiece name
    forM_ (mapToList dm) $ \(pkg, pd) -> do
        [pid] <- selectKeysList [PackageName ==. pkg] []
        [spid] <- selectKeysList [SnapshotPackageSnapshot ==. sid, SnapshotPackagePackage ==. pid] []
        forM_ (mapToList $ pdModules pd) $ \(mname, _paths) ->
            insert_ Module
                { modulePackage = spid
                , moduleName = mname
                }

run :: GetStackageDatabase m => SqlPersistT IO a -> m a
run inner = do
    StackageDatabase pool <- getStackageDatabase
    liftIO $ runSqlPool inner pool

newestLTS :: GetStackageDatabase m => m (Maybe (Int, Int))
newestLTS =
    run $ liftM (fmap go) $ selectFirst [] [Desc LtsMajor, Desc LtsMinor]
  where
    go (Entity _ lts) = (ltsMajor lts, ltsMinor lts)

newestLTSMajor :: GetStackageDatabase m => Int -> m (Maybe Int)
newestLTSMajor x =
    run $ liftM (fmap $ ltsMinor . entityVal) $ selectFirst [LtsMajor ==. x] [Desc LtsMinor]

ltsMajorVersions :: GetStackageDatabase m => m [(Int, Int)]
ltsMajorVersions =
    run $ liftM (dropOldMinors . map (toPair . entityVal))
        $ selectList [] [Desc LtsMajor, Desc LtsMinor]
  where
    toPair (Lts _ x y) = (x, y)

    dropOldMinors [] = []
    dropOldMinors (l@(x, _):rest) =
        l : dropOldMinors (dropWhile sameMinor rest)
      where
        sameMinor (y, _) = x == y

newestNightly :: GetStackageDatabase m => m (Maybe Day)
newestNightly =
    run $ liftM (fmap $ nightlyDay . entityVal) $ selectFirst [] [Desc NightlyDay]

lookupSnapshot :: GetStackageDatabase m => SnapName -> m (Maybe (Entity Snapshot))
lookupSnapshot name = run $ getBy $ UniqueSnapshot name

snapshotTitle :: Snapshot -> Text
snapshotTitle s = prettyName (snapshotName s) (snapshotGhc s)

prettyName :: SnapName -> Text -> Text
prettyName name ghc =
    concat [base, " - GHC ", ghc]
  where
    base =
        case name of
            SNLts x y -> concat ["LTS Haskell ", tshow x, ".", tshow y]
            SNNightly d -> "Stackage Nightly " ++ tshow d

getAllPackages :: GetStackageDatabase m => m [(Text, Text, Text)] -- FIXME add information on whether included in LTS and Nightly
getAllPackages = liftM (map toPair) $ run $ do
    E.select $ E.from $ \p -> do
        E.orderBy [E.asc $ p E.^. PackageName]
        return
            ( p E.^. PackageName
            , p E.^. PackageLatest
            , p E.^. PackageSynopsis
            )
  where
    toPair (E.Value x, E.Value y, E.Value z) = (x, y, z)

data PackageListingInfo = PackageListingInfo
    { pliName :: !Text
    , pliVersion :: !Text
    , pliSynopsis :: !Text
    , pliIsCore :: !Bool
    }

getPackages :: GetStackageDatabase m => SnapshotId -> m [PackageListingInfo]
getPackages sid = liftM (map toPLI) $ run $ do
    E.select $ E.from $ \(p,sp) -> do
        E.where_ $
            (p E.^. PackageId E.==. sp E.^. SnapshotPackagePackage) E.&&.
            (sp E.^. SnapshotPackageSnapshot E.==. E.val sid)
        E.orderBy [E.asc $ p E.^. PackageName]
        return
            ( p E.^. PackageName
            , p E.^. PackageSynopsis
            , sp E.^. SnapshotPackageVersion
            , sp E.^. SnapshotPackageIsCore
            )
  where
    toPLI (E.Value name, E.Value synopsis, E.Value version, E.Value isCore) = PackageListingInfo
        { pliName = name
        , pliVersion = version
        , pliSynopsis = synopsis
        , pliIsCore = isCore
        }

data ModuleListingInfo = ModuleListingInfo
    { mliName :: !Text
    , mliPackageVersion :: !Text
    }

getSnapshotModules
    :: GetStackageDatabase m
    => SnapshotId
    -> m [ModuleListingInfo]
getSnapshotModules sid = liftM (map toMLI) $ run $ do
    E.select $ E.from $ \(p,sp,m) -> do
        E.where_ $
            (p E.^. PackageId E.==. sp E.^. SnapshotPackagePackage) E.&&.
            (sp E.^. SnapshotPackageSnapshot E.==. E.val sid) E.&&.
            (m E.^. ModulePackage E.==. sp E.^. SnapshotPackageId)
        E.orderBy
            [ E.asc $ m E.^. ModuleName
            , E.asc $ p E.^. PackageName
            ]
        return
            ( m E.^. ModuleName
            , p E.^. PackageName
            , sp E.^. SnapshotPackageVersion
            )
  where
    toMLI (E.Value name, E.Value pkg, E.Value version) = ModuleListingInfo
        { mliName = name
        , mliPackageVersion = concat [pkg, "-", version]
        }

getPackageModules
    :: GetStackageDatabase m
    => SnapName
    -> Text
    -> m [Text]
getPackageModules sname pname = run $ do
    sids <- selectKeysList [SnapshotName ==. sname] []
    pids <- selectKeysList [PackageName ==. pname] []
    case (,) <$> listToMaybe sids <*> listToMaybe pids of
        Nothing -> return []
        Just (sid, pid) -> do
            spids <- selectKeysList
                [ SnapshotPackageSnapshot ==. sid
                , SnapshotPackagePackage ==. pid
                ] []
            case spids of
                spid:_ -> map (moduleName . entityVal)
                      <$> selectList [ModulePackage ==. spid] [Asc ModuleName]
                [] -> return []

lookupSnapshotPackage
    :: GetStackageDatabase m
    => SnapshotId
    -> Text
    -> m (Maybe (Entity SnapshotPackage))
lookupSnapshotPackage sid pname = run $ do
    mp <- getBy $ UniquePackage pname
    case mp of
        Nothing -> return Nothing
        Just (Entity pid _) -> getBy $ UniqueSnapshotPackage sid pid

getDeprecated :: GetStackageDatabase m => Text -> m (Bool, [Text])
getDeprecated name = run $ do
    pids <- selectKeysList [PackageName ==. name] []
    case pids of
        [pid] -> do
            mdep <- getBy $ UniqueDeprecated pid
            case mdep of
                Nothing -> return defRes
                Just (Entity _ (Deprecated _ favors)) -> do
                    names <- mapM getName favors
                    return (True, catMaybes names)
        _ -> return defRes
  where
    defRes = (False, [])

    getName = fmap (fmap packageName) . get

data LatestInfo = LatestInfo
    { liSnapName :: !SnapName
    , liVersion :: !Text
    , liGhc :: !Text
    }
    deriving Show

getLatests :: GetStackageDatabase m
           => Text -- ^ package name
           -> m [LatestInfo]
getLatests pname = run $ do
    mnightly <- latestHelper pname $ \s ln -> s E.^. SnapshotId E.==. ln E.^. NightlySnap
    mlts <- latestHelper pname $ \s ln -> s E.^. SnapshotId E.==. ln E.^. LtsSnap
    return $ concat [mnightly, mlts]

latestHelper
    :: (From E.SqlQuery E.SqlExpr SqlBackend t, MonadIO m, Functor m)
    => Text
    -> (E.SqlExpr (Entity Snapshot) -> t -> E.SqlExpr (E.Value Bool))
    -> ReaderT SqlBackend m [LatestInfo]
latestHelper pname clause = fmap (fmap toLatest) $ E.select $ E.from $ \(s,ln,p,sp) -> do
    E.where_ $
        clause s ln E.&&.
        (s E.^. SnapshotId E.==. sp E.^. SnapshotPackageSnapshot) E.&&.
        (p E.^. PackageName E.==. E.val pname) E.&&.
        (p E.^. PackageId E.==. sp E.^. SnapshotPackagePackage)
    E.orderBy [E.desc $ s E.^. SnapshotCreated]
    E.limit 1
    return
        ( s E.^. SnapshotName
        , s E.^. SnapshotGhc
        , sp E.^. SnapshotPackageVersion
        )
  where
    toLatest (E.Value sname, E.Value ghc, E.Value version) = LatestInfo
        { liSnapName = sname
        , liVersion = version
        , liGhc = ghc
        }

getDeps :: GetStackageDatabase m => Text -> m [(Text, Text)]
getDeps pname = run $ do
    Just (Entity pid _) <- getBy $ UniquePackage pname
    fmap (map toPair) $ E.select $ E.from $ \d -> do
        E.where_ $
            (d E.^. DepUser E.==. E.val pid)
        E.orderBy [E.asc $ d E.^. DepUses]
        return (d E.^. DepUses, d E.^. DepRange)
  where
    toPair (E.Value x, E.Value y) = (x, y)

getRevDeps :: GetStackageDatabase m => Text -> m [(Text, Text)]
getRevDeps pname = run $ do
    fmap (map toPair) $ E.select $ E.from $ \(d,p) -> do
        E.where_ $
            (d E.^. DepUses E.==. E.val pname) E.&&.
            (d E.^. DepUser E.==. p E.^. PackageId)
        E.orderBy [E.asc $ p E.^. PackageName]
        return (p E.^. PackageName, d E.^. DepRange)
  where
    toPair (E.Value x, E.Value y) = (x, y)

getPackage :: GetStackageDatabase m => Text -> m (Maybe (Entity Package))
getPackage = run . getBy . UniquePackage

getSnapshotsForPackage
    :: GetStackageDatabase m
    => Text
    -> m [(Snapshot, Text)] -- version
getSnapshotsForPackage pname = run $ do
    pid <- getPackageId pname
    sps <- selectList [SnapshotPackagePackage ==. pid] []
    fmap catMaybes $ forM sps $ \(Entity _ sp) -> do
        let sid = snapshotPackageSnapshot sp
        ms <- get sid
        return $ case ms of
            Nothing -> Nothing
            Just s -> Just (s, snapshotPackageVersion sp)

getSnapshots
    :: GetStackageDatabase m
    => Int -- ^ limit
    -> Int -- ^ offset
    -> m (Int, [Snapshot])
getSnapshots l o = run $ (,)
    <$> count ([] :: [Filter Snapshot])
    <*> fmap (map entityVal) (selectList
        []
        [LimitTo l, OffsetBy o, Desc SnapshotCreated])

last5Lts5Nightly :: GetStackageDatabase m => m [SnapName]
last5Lts5Nightly = run $ do
    ls <- selectList [] [Desc LtsMajor, Desc LtsMinor, LimitTo 5]
    ns <- selectList [] [Desc NightlyDay, LimitTo 5]
    return $ map l ls ++ map n ns
  where
    l (Entity _ x) = SNLts (ltsMajor x) (ltsMinor x)
    n (Entity _ x) = SNNightly (nightlyDay x)