GetStackageDatabase typeclass

Foundation.hs

@@ -275,5 +275,7 @@ getExtra = fmap (appExtra . settings) getYesod
 --
 -- https://github.com/yesodweb/yesod/wiki/Sending-email
 
-getStackageDatabase :: Handler StackageDatabase
-getStackageDatabase = getYesod >>= readIORef . stackageDatabase
+instance GetStackageDatabase Handler where
+    getStackageDatabase = getYesod >>= readIORef . stackageDatabase
+instance GetStackageDatabase (WidgetT App IO) where
+    getStackageDatabase = getYesod >>= readIORef . stackageDatabase

Handler/OldLinks.hs

@@ -24,35 +24,32 @@ parseLtsSuffix t0 = do
 
 getOldLtsR :: [Text] -> Handler ()
 getOldLtsR pieces = do
-    db <- getStackageDatabase
     (x, y, pieces') <- case pieces of
         t:ts | Just suffix <- parseLtsSuffix t -> do
             (x, y) <- case suffix of
                 LSMajor x -> do
-                    y <- newestLTSMajor db x >>= maybe notFound return
+                    y <- newestLTSMajor x >>= maybe notFound return
                     return (x, y)
                 LSMinor x y -> return (x, y)
             return (x, y, ts)
         _ -> do
-            (x, y) <- newestLTS db >>= maybe notFound return
+            (x, y) <- newestLTS >>= maybe notFound return
             return (x, y, pieces)
     let name = concat ["lts-", tshow x, ".", tshow y]
     redirect $ concatMap (cons '/') $ name : pieces'
 
 getOldLtsMajorR :: LtsMajor -> [Text] -> Handler ()
 getOldLtsMajorR (LtsMajor x) pieces = do
-    db <- getStackageDatabase
-    y <- newestLTSMajor db x >>= maybe notFound return
+    y <- newestLTSMajor x >>= maybe notFound return
     let name = concat ["lts-", tshow x, ".", tshow y]
     redirect $ concatMap (cons '/') $ name : pieces
 
 getOldNightlyR :: [Text] -> Handler ()
 getOldNightlyR pieces = do
-    db <- getStackageDatabase
     (day, pieces') <- case pieces of
         t:ts | Just day <- fromPathPiece t -> return (day, ts)
         _ -> do
-            day <- newestNightly db >>= maybe notFound return
+            day <- newestNightly >>= maybe notFound return
             return (day, pieces)
     let name = "nightly-" ++ tshow day
     redirect $ concatMap (cons '/') $ name : pieces'

Handler/StackageHome.hs

@@ -12,8 +12,7 @@ import Stackage.Database
 
 getStackageHomeR :: SnapName -> Handler Html
 getStackageHomeR name = do
-    db <- getStackageDatabase
-    Entity sid snapshot <- lookupSnapshot db name >>= maybe notFound return
+    Entity sid snapshot <- lookupSnapshot name >>= maybe notFound return
 
     let hoogleForm =
             let queryText = "" :: Text
@@ -21,7 +20,7 @@ getStackageHomeR name = do
             in $(widgetFile "hoogle-form")
     defaultLayout $ do
         setTitle $ toHtml $ snapshotTitle snapshot
-        packages <- getPackages db sid
+        packages <- getPackages sid
         $(widgetFile "stackage-home")
   where strip x = fromMaybe x (stripSuffix "." x)
 

Stackage/Database.hs

@@ -1,5 +1,6 @@
 module Stackage.Database
     ( StackageDatabase
+    , GetStackageDatabase (..)
     , SnapName (..)
     , Snapshot (..)
     , loadStackageDatabase
@@ -60,6 +61,9 @@ SnapshotPackage
 
 newtype StackageDatabase = StackageDatabase ConnectionPool
 
+class MonadIO m => GetStackageDatabase m where
+    getStackageDatabase :: m StackageDatabase
+
 sourceBuildPlans :: MonadResource m => Producer m (SnapName, BuildPlan)
 sourceBuildPlans = do
     root <- liftIO $ fmap (</> "database") $ fmap fpFromString $ getAppUserDataDirectory "stackage"
@@ -147,25 +151,28 @@ addPlan (name, bp) = do
         $ fmap (, True) (siCorePackages $ bpSystemInfo bp)
        ++ fmap ((, False) . ppVersion) (bpPackages bp)
 
-run :: MonadIO m => StackageDatabase -> SqlPersistT IO a -> m a
-run (StackageDatabase pool) inner = liftIO $ runSqlPool inner pool
 
-newestLTS :: MonadIO m => StackageDatabase -> m (Maybe (Int, Int))
-newestLTS db =
-    run db $ liftM (fmap go) $ selectFirst [] [Desc LtsMajor, Desc LtsMinor]
+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 :: MonadIO m => StackageDatabase -> Int -> m (Maybe Int)
-newestLTSMajor db x =
-    run db $ liftM (fmap $ ltsMinor . entityVal) $ selectFirst [LtsMajor ==. x] [Desc LtsMinor]
+newestLTSMajor :: GetStackageDatabase m => Int -> m (Maybe Int)
+newestLTSMajor x =
+    run $ liftM (fmap $ ltsMinor . entityVal) $ selectFirst [LtsMajor ==. x] [Desc LtsMinor]
 
-newestNightly :: MonadIO m => StackageDatabase -> m (Maybe Day)
-newestNightly db =
-    run db $ liftM (fmap $ nightlyDay . entityVal) $ selectFirst [] [Desc NightlyDay]
+newestNightly :: GetStackageDatabase m => m (Maybe Day)
+newestNightly =
+    run $ liftM (fmap $ nightlyDay . entityVal) $ selectFirst [] [Desc NightlyDay]
 
-lookupSnapshot :: MonadIO m => StackageDatabase -> SnapName -> m (Maybe (Entity Snapshot))
-lookupSnapshot db name = run db $ getBy $ UniqueSnapshot name
+lookupSnapshot :: GetStackageDatabase m => SnapName -> m (Maybe (Entity Snapshot))
+lookupSnapshot name = run $ getBy $ UniqueSnapshot name
 
 snapshotTitle :: Snapshot -> Text
 snapshotTitle s =
@@ -182,8 +189,8 @@ data PackageListingInfo = PackageListingInfo
     , pliSynopsis :: !Text
     }
 
-getPackages :: MonadIO m => StackageDatabase -> SnapshotId -> m [PackageListingInfo]
-getPackages db sid = liftM (map toPLI) $ run db $ do
+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.&&.