[#104] Add functionality for associating repos with their categories (#…

…123)

issue-wanted.cabal

@@ -96,8 +96,10 @@ library
 
                          -- Sync Worker
                          IW.Sync.Search
+                         IW.Sync.Update
 
   build-depends:       aeson >= 1.4
+                     , async ^>= 2.2.2
                      , bytestring ^>= 0.10
                      , Cabal ^>= 2.4.1.0
                      , case-insensitive ^>= 1.2
@@ -118,6 +120,8 @@ library
                      , text
                      , time >= 1.8 && < 1.10
                      , tomland ^>= 1.0.0
+                     , unliftio ^>= 0.2.12
+                     , unliftio-core ^>= 0.1.2.0
                      , unordered-containers
                      , vector ^>= 0.12.0.3
                      , warp ^>= 3.2

src/IW/App/Error.hs

@@ -2,11 +2,12 @@
 
 module IW.App.Error
        ( AppError (..)
-       , AppErrorType
+       , AppErrorType (..)
        , AppException (..)
        , WithError
        , githubErrToAppErr
        , throwError
+       , catchError
        , toHttpError
 
          -- * Error checks
@@ -22,6 +23,7 @@ module IW.App.Error
        , missingHeader
        , headerDecodeError
        , dbError
+       , urlDownloadFailedError
 
          -- * Error throwing helpers
        , throwOnNothing
@@ -36,19 +38,26 @@ import GHC.Stack (SrcLoc (SrcLoc, srcLocModule, srcLocStartLine))
 import Network.HTTP.Types.Header (HeaderName)
 import Servant.Server (err401, err404, err417, err500, errBody)
 
-import qualified Control.Monad.Except as E (throwError)
+import IW.Core.Url (Url (..))
+
+import qualified Control.Monad.Except as E (throwError, catchError)
 import qualified GitHub
 import qualified Servant.Server as Servant (ServerError)
 
 
 -- | Type alias for errors.
 type WithError m = (MonadError AppError m, HasCallStack)
 
--- | Specialized version of 'E.throwError'
+-- | Specialized version of 'E.throwError'.
 throwError :: WithError m => AppErrorType -> m a
 throwError = E.throwError . AppError (toSourcePosition callStack)
 {-# INLINE throwError #-}
 
+-- | Specialized version of 'E.catchError'.
+catchError :: WithError m => m a -> (AppErrorType -> m a) -> m a
+catchError action handler = action `E.catchError` (handler . appErrorType)
+{-# INLINE catchError #-}
+
 newtype SourcePosition = SourcePosition Text
     deriving newtype (Show, Eq)
 
@@ -81,9 +90,10 @@ data AppError = AppError
     } deriving (Show, Eq)
 
 -- | App errors type.
-data AppErrorType 
+data AppErrorType
     = InternalError IError
     | GitHubError GError
+    | UrlDownloadFailed Url
     deriving (Show, Eq)
 
 {- | The internal errors that can be thrown. These errors are meant to be
@@ -113,9 +123,9 @@ data IError
     | DbError Text
     deriving (Show, Eq)
 
-{- | Errors from the @github@ library search functions that can be thrown. 
+{- | Errors from the @github@ library search functions that can be thrown.
 -}
-data GError 
+data GError
     {- | A HTTP error occurred. The actual caught error is included. -}
     = HTTPError Text
     {- | An error in the parser itself. -}
@@ -129,11 +139,11 @@ data GError
 -- | Map the @github@ library's @Error@ type into AppErrorType.
 githubErrToAppErr :: GitHub.Error -> AppErrorType
 githubErrToAppErr = \case
-    GitHub.HTTPError httpException -> GitHubError $ HTTPError $ show httpException 
-    GitHub.ParseError text         -> GitHubError $ ParseError text 
+    GitHub.HTTPError httpException -> GitHubError $ HTTPError $ show httpException
+    GitHub.ParseError text         -> GitHubError $ ParseError text
     GitHub.JsonError text          -> GitHubError $ JsonError text
     GitHub.UserError text          -> GitHubError $ UserError text
- 
+
 -- | Map 'AppError' into a HTTP error code.
 toHttpError :: AppError -> Servant.ServerError
 toHttpError (AppError _callStack errorType) = case errorType of
@@ -146,6 +156,7 @@ toHttpError (AppError _callStack errorType) = case errorType of
         HeaderDecodeError name -> err401 { errBody = encodeUtf8 $ "Unable to decode header: " <> name }
         DbError e              -> err500 { errBody = encodeUtf8 e }
     GitHubError err -> err500 { errBody = show err }
+    UrlDownloadFailed url -> err500 { errBody = encodeUtf8 $ "Couldn't download file from " <> unUrl url }
 
 ----------------------------------------------------------------------------
 -- Error checks
@@ -188,6 +199,9 @@ headerDecodeError = InternalError . HeaderDecodeError
 dbError :: Text -> AppErrorType
 dbError = InternalError . DbError
 
+urlDownloadFailedError :: Url -> AppErrorType
+urlDownloadFailedError = UrlDownloadFailed
+
 ----------------------------------------------------------------------------
 -- Helpers
 ----------------------------------------------------------------------------

src/IW/App/Monad.hs

@@ -7,6 +7,7 @@ module IW.App.Monad
 
 import Control.Exception (catch, throwIO, try)
 import Control.Monad.Except (MonadError (..))
+import Control.Monad.IO.Unlift (MonadUnliftIO (..))
 import Relude.Extra.Bifunctor (firstF)
 
 import IW.App.Env (Env)
@@ -19,7 +20,7 @@ type AppEnv = Env App
 -- | Main application monad.
 newtype App a = App
     { unApp :: ReaderT AppEnv IO a
-    } deriving (Functor, Applicative, Monad, MonadIO, MonadReader AppEnv)
+    } deriving (Functor, Applicative, Monad, MonadIO, MonadReader AppEnv, MonadUnliftIO)
 
 instance MonadError AppError App where
     throwError :: AppError -> App a

src/IW/Db/Repo.hs

@@ -6,24 +6,25 @@ module IW.Db.Repo
        ( getRepos
        , getReposByCategories
        , upsertRepos
+       , updateRepoCategories
        ) where
 
-import IW.Core.Repo (Repo (..), Category (..))
+import IW.Core.Repo (Repo, RepoOwner, RepoName, Category)
 import IW.Core.SqlArray (SqlArray (..))
 import IW.Core.WithId (WithId)
-import IW.Db.Functions (WithDb, executeMany, query, queryRaw)
+import IW.Db.Functions (WithDb, executeMany, execute, query, queryRaw)
 
 
 -- | Returns all repos in the database.
-getRepos :: (WithDb env m) => m [WithId Repo]
+getRepos :: WithDb env m => m [WithId Repo]
 getRepos = queryRaw [sql|
     SELECT id, owner, name, descr, categories
     FROM repos
     LIMIT 100
 |]
 
 -- | Returns all repos with at least one category in the given list.
-getReposByCategories :: (WithDb env m) => [Category] -> m [WithId Repo]
+getReposByCategories :: WithDb env m => [Category] -> m [WithId Repo]
 getReposByCategories = query [sql|
     SELECT id, owner, name, descr, categories
     FROM repos
@@ -32,7 +33,7 @@ getReposByCategories = query [sql|
 |] . Only . SqlArray
 
 -- | Insert a list of repos into the database, but update on conflict.
-upsertRepos :: (WithDb env m) => [Repo] -> m ()
+upsertRepos :: WithDb env m => [Repo] -> m ()
 upsertRepos = executeMany [sql|
     INSERT INTO repos
         (owner, name, descr, categories)
@@ -43,3 +44,17 @@ upsertRepos = executeMany [sql|
         descr = EXCLUDED.descr
       , categories = EXCLUDED.categories;
 |]
+
+-- | Update a repo's categories field.
+updateRepoCategories
+    :: WithDb env m
+    => RepoOwner
+    -> RepoName
+    -> [Category]
+    -> m ()
+updateRepoCategories repoOwner repoName categories = execute [sql|
+    UPDATE repos
+    SET categories = ?
+    WHERE owner = ?
+      AND name = ?
+|] (SqlArray categories, repoOwner, repoName)

src/IW/Effects/Cabal.hs

@@ -17,10 +17,10 @@ import Data.Text (splitOn, strip)
 import Distribution.PackageDescription
 import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe)
 
-import IW.App (App)
+import IW.App (App (..), WithError)
 import IW.Core.Repo (RepoOwner (..), RepoName (..), Category (..))
 import IW.Core.Url (Url (..))
-import IW.Effects.Download (MonadDownload (..))
+import IW.Effects.Download (MonadDownload (..), downloadFileMaybe)
 
 
 -- | Describes a monad that returns @[Category]@ given a @RepoOwner@ and @RepoName@.
@@ -30,18 +30,23 @@ class Monad m => MonadCabal m where
 instance MonadCabal App where
     getCabalCategories = getCabalCategoriesImpl
 
-type WithCabal env m = (MonadDownload m, WithLog env m)
+type WithCabal env m = (MonadDownload m, WithLog env m, WithError m)
 
 {- | This function may throw anyone of the errors inherited by the use of @downloadFile@
 defined in @IW.Effects.Download@. We are using @parseGenericPackageDescriptionMaybe@
 which will return @Nothing@ on an unsuccessful parse.
 -}
-getCabalCategoriesImpl :: WithCabal env m => RepoOwner -> RepoName -> m [Category]
+getCabalCategoriesImpl
+    :: forall env m.
+       WithCabal env m
+    => RepoOwner
+    -> RepoName
+    -> m [Category]
 getCabalCategoriesImpl repoOwner repoName = do
-    cabalFile <- downloadFile cabalUrl
-    case parseGenericPackageDescriptionMaybe cabalFile of
+    maybeCabalFile <- downloadFileMaybe cabalUrl
+    case maybeCabalFile >>= parseGenericPackageDescriptionMaybe of
         Nothing -> do
-            log E $ "Couldn't parse file downloaded from " <> unUrl cabalUrl
+            log W $ "Couldn't parse file downloaded from " <> unUrl cabalUrl
             pure []
         Just genPkgDescr -> do
             log I $ "Successfully parsed file downloaded from " <> unUrl cabalUrl
@@ -63,13 +68,16 @@ repoCabalUrl (RepoOwner repoOwner) (RepoName repoName) = Url $
 
 -- | Parses a comma separated @Text@ value to @[Category]@.
 categoryNames :: GenericPackageDescription -> [Category]
-categoryNames genPkgDescr = Category . strip <$> splitCategories genPkgDescr
+categoryNames genPkgDescr = Category <$> splitCategories genPkgDescr
   where
     splitCategories :: GenericPackageDescription -> [Text]
-    splitCategories = splitOnNonEmptyText "," . toText . category . packageDescription
+    splitCategories = splitAndStrip "," . toText . category . packageDescription
 
-    -- | A variation of @splitOn@ that returns @[]@ instead of @[""]@
-    -- if the text to be split is empty.
-    splitOnNonEmptyText :: Text -> Text -> [Text]
-    splitOnNonEmptyText _ ""       = []
-    splitOnNonEmptyText delim text = splitOn delim text
+{- | This function takes a delimeter and a delimeter seperated value,
+and returns a list of @Text@ values stripped of excess whitespace.
+Note that it returns an empty list when an empty delimeter seperated value is
+passed in. This prevents the value @[""]@ from being returned.
+-}
+splitAndStrip :: Text -> Text -> [Text]
+splitAndStrip _ ""       = []
+splitAndStrip delim text = strip <$> splitOn delim text

src/IW/Effects/Download.hs

@@ -5,6 +5,7 @@ an instance of @MonadDownload@ for the @App@ monad. Instances of
 
 module IW.Effects.Download
        ( MonadDownload (..)
+       , downloadFileMaybe
 
        -- * Internals
        , downloadFileImpl
@@ -13,7 +14,7 @@ module IW.Effects.Download
 import Network.HTTP.Client (Manager, Response (..), httpLbs)
 import Network.HTTP.Types (Status (..))
 
-import IW.App (App, Has, WithError, grab, throwError, notFound)
+import IW.App (App, AppErrorType (..), Has, WithError, grab, throwError, catchError, urlDownloadFailedError)
 import IW.Core.Url (Url (..))
 
 
@@ -27,10 +28,10 @@ instance MonadDownload App where
 type WithDownload env m = (MonadIO m, MonadReader env m, WithError m, WithLog env m, Has Manager env)
 
 downloadFileImpl :: WithDownload env m => Url -> m ByteString
-downloadFileImpl Url{..} = do
+downloadFileImpl url@Url{..} = do
     man <- grab @Manager
     let req = fromString $ toString unUrl
-    log I $ "Attempting to download file from " <> unUrl <> "..."
+    log I $ "Attempting to download file from " <> unUrl <> " ..."
     response <- liftIO $ httpLbs req man
     let status = statusCode $ responseStatus response
     let body = responseBody response
@@ -40,5 +41,10 @@ downloadFileImpl Url{..} = do
             log I $ "Successfully downloaded file from " <> unUrl
             pure $ toStrict body
         _   -> do
-            log W $ "Couldn't download file from " <> unUrl
-            throwError notFound
+            log E $ "Couldn't download file from " <> unUrl
+            throwError $ urlDownloadFailedError url
+
+downloadFileMaybe :: (MonadDownload m, WithError m) => Url -> m (Maybe ByteString)
+downloadFileMaybe url = (Just <$> downloadFile url) `catchError` \case
+    UrlDownloadFailed _ -> pure Nothing
+    err -> throwError err