├── .github └── CODEOWNERS ├── frontend ├── package-lock.json ├── elmapp.config.js ├── src │ ├── index.js │ ├── main.css │ ├── IW │ │ ├── Core │ │ │ ├── Types.elm │ │ │ ├── Encoder.elm │ │ │ ├── Decoder.elm │ │ │ └── ElmStreet.elm │ │ ├── Cmd.elm │ │ └── Api.elm │ ├── Main.elm │ └── registerServiceWorker.js ├── .gitignore ├── public │ ├── manifest.json │ └── index.html └── elm.json ├── app └── Main.hs ├── config.toml ├── Dockerfile ├── sql ├── drop.sql ├── seed.sql └── schema.sql ├── stack.yaml ├── src ├── IW │ ├── App.hs │ ├── Db.hs │ ├── Core │ │ ├── Url.hs │ │ ├── SqlArray.hs │ │ ├── Id.hs │ │ ├── WithId.hs │ │ ├── Issue.hs │ │ └── Repo.hs │ ├── Server │ │ ├── Types.hs │ │ ├── Issue.hs │ │ └── Repo.hs │ ├── Time.hs │ ├── Config.hs │ ├── Server.hs │ ├── Db │ │ ├── Schema.hs │ │ ├── Issue.hs │ │ ├── Repo.hs │ │ └── Functions.hs │ ├── App │ │ ├── Env.hs │ │ ├── Monad.hs │ │ └── Error.hs │ ├── Sync │ │ ├── Update.hs │ │ └── Search.hs │ └── Effects │ │ ├── Log.hs │ │ ├── Download.hs │ │ └── Cabal.hs ├── IW.hs └── Prelude.hs ├── CHANGELOG.md ├── Makefile ├── test ├── Test │ ├── Common.hs │ ├── Gen.hs │ ├── Core │ │ ├── Repo.hs │ │ └── Issue.hs │ ├── Data.hs │ ├── Assert.hs │ ├── Db.hs │ └── Sync.hs └── Spec.hs ├── generate-elm └── Main.hs ├── .gitignore ├── .circleci └── config.yml ├── README.md ├── issue-wanted.cabal ├── .stylish-haskell.yaml └── LICENSE /.github/CODEOWNERS: -------------------------------------------------------------------------------- 1 | * @chshersh @vrom911 -------------------------------------------------------------------------------- /frontend/package-lock.json: -------------------------------------------------------------------------------- 1 | { 2 | "lockfileVersion": 1 3 | } 4 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified IW 4 | 5 | 6 | main :: IO () 7 | main = IW.main 8 | -------------------------------------------------------------------------------- /config.toml: -------------------------------------------------------------------------------- 1 | dbCredentials = "host=localhost port=5432 user=root dbname=issue-wanted" 2 | log.severity = "Debug" -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM fpco/stack-build:lts-14.5 2 | RUN apt-get update -y && apt-get install libpq-dev postgresql -y 3 | -------------------------------------------------------------------------------- /sql/drop.sql: -------------------------------------------------------------------------------- 1 | -- To execute this file from SQL REPL: 2 | -- \i sql/drop.sql 3 | 4 | DROP TABLE IF EXISTS repos CASCADE; 5 | DROP TABLE IF EXISTS issues; 6 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.5 2 | 3 | extra-deps: 4 | - postgresql-simple-named-0.0.2.0 5 | 6 | # github 7 | - github-0.22 8 | - binary-instances-1 9 | - binary-orphans-1.0.1 10 | -------------------------------------------------------------------------------- /src/IW/App.hs: -------------------------------------------------------------------------------- 1 | module IW.App 2 | ( module IW.App.Env 3 | , module IW.App.Error 4 | , module IW.App.Monad 5 | ) where 6 | 7 | import IW.App.Env 8 | import IW.App.Error 9 | import IW.App.Monad 10 | -------------------------------------------------------------------------------- /src/IW/Db.hs: -------------------------------------------------------------------------------- 1 | -- | All database-related functions. 2 | 3 | module IW.Db 4 | ( module Db 5 | ) where 6 | 7 | import IW.Db.Functions as Db 8 | import IW.Db.Schema as Db 9 | import IW.Db.Issue as Db 10 | import IW.Db.Repo as Db 11 | -------------------------------------------------------------------------------- /frontend/elmapp.config.js: -------------------------------------------------------------------------------- 1 | module.exports = { 2 | inline: true, 3 | historyApiFallback: true, 4 | proxy:{ 5 | '/':{ 6 | target: 'http://localhost:8080', 7 | secure: false 8 | } 9 | } 10 | } 11 | -------------------------------------------------------------------------------- /src/IW/Core/Url.hs: -------------------------------------------------------------------------------- 1 | module IW.Core.Url 2 | ( Url (..) 3 | ) where 4 | 5 | 6 | newtype Url = Url 7 | { unUrl :: Text 8 | } deriving stock (Generic) 9 | deriving newtype (Eq, Ord, Show, FromField, ToField, ToJSON, Elm) 10 | -------------------------------------------------------------------------------- /frontend/src/index.js: -------------------------------------------------------------------------------- 1 | import './main.css'; 2 | import { Elm } from './Main.elm'; 3 | import registerServiceWorker from './registerServiceWorker'; 4 | 5 | Elm.Main.init({ 6 | node: document.getElementById('root') 7 | }); 8 | 9 | registerServiceWorker(); 10 | -------------------------------------------------------------------------------- /frontend/.gitignore: -------------------------------------------------------------------------------- 1 | # Distribution 2 | build/ 3 | 4 | # elm-package generated files 5 | elm-stuff 6 | 7 | # elm-repl generated files 8 | repl-temp-* 9 | 10 | # Dependency directories 11 | node_modules 12 | 13 | # Desktop Services Store on macOS 14 | .DS_Store 15 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | Change log 2 | ========== 3 | 4 | issue-wanted uses [PVP Versioning][1]. 5 | The change log is available [on GitHub][2]. 6 | 7 | 0.0.0 8 | ===== 9 | * Initially created. 10 | 11 | [1]: https://pvp.haskell.org 12 | [2]: https://github.com/kowainik/issue-wanted/releases 13 | 14 | -------------------------------------------------------------------------------- /frontend/public/manifest.json: -------------------------------------------------------------------------------- 1 | { 2 | "short_name": "Issue Wanted", 3 | "name": "🏷 Web application to help beginners to start contributing into Haskell projects", 4 | "icons": [], 5 | "start_url": "./index.html", 6 | "display": "standalone", 7 | "theme_color": "#000000", 8 | "background_color": "#ffffff" 9 | } 10 | -------------------------------------------------------------------------------- /frontend/src/main.css: -------------------------------------------------------------------------------- 1 | body { 2 | font-family: 'Source Sans Pro', 'Trebuchet MS', 'Lucida Grande', 'Bitstream Vera Sans', 'Helvetica Neue', sans-serif; 3 | margin: 0; 4 | text-align: center; 5 | color: #293c4b; 6 | } 7 | 8 | h1 {font-size: 30px;} 9 | 10 | img { 11 | margin: 20px 0; 12 | max-width: 200px; 13 | } 14 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ide: 2 | ghcid --command "stack ghci --ghci-options=-fno-code issue-wanted:lib --main-is issue-wanted:exe:issue-wanted issue-wanted:test:issue-wanted-test" 3 | 4 | postgres: 5 | docker run -p 5432\:5432 -e POSTGRES_USER=root -e POSTGRES_DB=issue-wanted postgres\:10.5-alpine 6 | 7 | sql-repl: 8 | psql -h localhost -p 5432 -U root -d issue-wanted -------------------------------------------------------------------------------- /test/Test/Common.hs: -------------------------------------------------------------------------------- 1 | -- | Common helpers for writing tests. 2 | 3 | module Test.Common 4 | ( joinSpecs 5 | ) where 6 | 7 | import Test.Hspec (Spec, describe) 8 | 9 | import IW.App (AppEnv) 10 | 11 | 12 | -- | Joins list of specs into single test group with given name. 13 | joinSpecs :: String -> [AppEnv -> Spec] -> AppEnv -> Spec 14 | joinSpecs name specs env = describe name $ traverse_ ($ env) specs 15 | -------------------------------------------------------------------------------- /src/IW/Server/Types.hs: -------------------------------------------------------------------------------- 1 | -- | This module introduce aliases to use for @servant-generic@ types and functions writing. 2 | 3 | module IW.Server.Types 4 | ( AppServer 5 | , ToApi 6 | ) where 7 | 8 | import Servant.API.Generic (ToServantApi) 9 | import Servant.Server.Generic (AsServerT) 10 | 11 | import IW.App (App) 12 | 13 | 14 | type AppServer = AsServerT App 15 | type ToApi (site :: Type -> Type) = ToServantApi site 16 | -------------------------------------------------------------------------------- /frontend/src/IW/Core/Types.elm: -------------------------------------------------------------------------------- 1 | module IW.Core.Types exposing (..) 2 | 3 | import Time exposing (Posix) 4 | 5 | 6 | type alias Issue = 7 | { repoOwner : String 8 | , repoName : String 9 | , number : Int 10 | , title : String 11 | , body : String 12 | , labels : List String 13 | } 14 | 15 | type alias Repo = 16 | { owner : String 17 | , name : String 18 | , descr : String 19 | , categories : List String 20 | } 21 | -------------------------------------------------------------------------------- /src/IW/Core/SqlArray.hs: -------------------------------------------------------------------------------- 1 | module IW.Core.SqlArray 2 | ( SqlArray (..) 3 | ) where 4 | 5 | import Database.PostgreSQL.Simple.Types (PGArray (..)) 6 | 7 | 8 | newtype SqlArray a = SqlArray { unSqlArray :: [a] } 9 | deriving stock (Generic, Show) 10 | deriving newtype (Eq, ToJSON) 11 | deriving (ToField, FromField) via PGArray a 12 | 13 | instance Elm a => Elm (SqlArray a) where 14 | toElmDefinition _ = toElmDefinition (Proxy @[a]) 15 | -------------------------------------------------------------------------------- /generate-elm/Main.hs: -------------------------------------------------------------------------------- 1 | {- | Generates Elm types from Haskell @issue-wanted@ library. 2 | 3 | The generated files can be found in the @frontend/src/IW/Core/@ folder. 4 | -} 5 | 6 | module Main (main) where 7 | 8 | import Elm (defaultSettings, generateElm) 9 | 10 | import IW.Core.Issue (Issue) 11 | import IW.Core.Repo (Repo) 12 | 13 | 14 | type IwTypes = 15 | '[ Issue 16 | , Repo 17 | ] 18 | 19 | main :: IO () 20 | main = generateElm @IwTypes $ defaultSettings "frontend/src" ["IW", "Core"] 21 | -------------------------------------------------------------------------------- /src/IW/Time.hs: -------------------------------------------------------------------------------- 1 | module IW.Time 2 | ( getToday 3 | , julianDayToIso 4 | ) where 5 | 6 | import Data.Time (Day (..), getCurrentTime, utctDay) 7 | import Data.Time.Format (formatTime, defaultTimeLocale, iso8601DateFormat) 8 | 9 | 10 | -- | Returns today's date as a Julian day. 11 | getToday :: IO Day 12 | getToday = utctDay <$> getCurrentTime 13 | 14 | -- | Converts a Julian day to a date in ISO 8601 (yyyy-mm-dd) format. 15 | julianDayToIso :: Day -> Text 16 | julianDayToIso = fromString . formatTime defaultTimeLocale (iso8601DateFormat Nothing) 17 | -------------------------------------------------------------------------------- /test/Test/Gen.hs: -------------------------------------------------------------------------------- 1 | module Test.Gen where 2 | 3 | import Hedgehog (MonadGen) 4 | 5 | import IW.Core.Id (Id (..)) 6 | import IW.Core.Repo (RepoName (..), RepoOwner (..)) 7 | 8 | import qualified Hedgehog.Gen as Gen 9 | import qualified Hedgehog.Range as Range 10 | 11 | 12 | genId :: MonadGen m => m (Id a) 13 | genId = Id <$> Gen.int (Range.constant 1 500) 14 | 15 | genRepoOwner :: MonadGen m => m RepoOwner 16 | genRepoOwner = RepoOwner <$> Gen.text (Range.constant 1 20) Gen.alphaNum 17 | 18 | genRepoName :: MonadGen m => m RepoName 19 | genRepoName = RepoName <$> Gen.text (Range.constant 1 20) Gen.alphaNum 20 | -------------------------------------------------------------------------------- /frontend/src/IW/Cmd.elm: -------------------------------------------------------------------------------- 1 | -- This module contains function to work with 'Model', 'Cmd' and 'Sub'. 2 | 3 | module IW.Cmd exposing 4 | ( withCmd 5 | , noCmd 6 | , noSub 7 | , delay 8 | ) 9 | 10 | import Process 11 | import Task 12 | 13 | withCmd : Cmd msg -> model -> (model, Cmd msg) 14 | withCmd cmd model = (model, cmd) 15 | 16 | noCmd : model -> (model, Cmd msg) 17 | noCmd model = withCmd Cmd.none model 18 | 19 | noSub : model -> Sub msg 20 | noSub _ = Sub.none 21 | 22 | -- Delay sending out the msg by given number of milliseconds 23 | delay : Int -> msg -> Cmd msg 24 | delay millis msg = Process.sleep (toFloat millis) |> Task.perform (\_ -> msg) 25 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ### Haskell 2 | dist 3 | dist-* 4 | cabal-dev 5 | *.o 6 | *.hi 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | *.prof 12 | *.aux 13 | *.hp 14 | *.eventlog 15 | .virtualenv 16 | .hsenv 17 | .hpc 18 | .cabal-sandbox/ 19 | cabal.sandbox.config 20 | cabal.config 21 | cabal.project.local 22 | .ghc.environment.* 23 | .HTF/ 24 | # Stack 25 | .stack-work/ 26 | stack.yaml.lock 27 | 28 | ### IDE/support 29 | # Vim 30 | [._]*.s[a-v][a-z] 31 | [._]*.sw[a-p] 32 | [._]s[a-v][a-z] 33 | [._]sw[a-p] 34 | *~ 35 | tags 36 | 37 | # IntellijIDEA 38 | .idea/ 39 | .ideaHaskellLib/ 40 | *.iml 41 | 42 | # Atom 43 | .haskell-ghc-mod.json 44 | 45 | # VS 46 | .vscode/ 47 | 48 | # Emacs 49 | *# 50 | .dir-locals.el 51 | TAGS 52 | 53 | # other 54 | .DS_Store 55 | -------------------------------------------------------------------------------- /frontend/src/IW/Api.elm: -------------------------------------------------------------------------------- 1 | module IW.Api exposing 2 | ( ResultErr 3 | , getIssues 4 | ) 5 | 6 | import Http exposing (Error) 7 | import Json.Decode as D 8 | import Json.Encode as E 9 | import Url exposing (Url) 10 | 11 | import IW.Core.Types exposing (Issue) 12 | import IW.Core.Decoder exposing (decodeIssue) 13 | 14 | 15 | type alias ResultErr a = Result Error a 16 | 17 | getIssues : List String -> Int -> (ResultErr (List Issue) -> msg) -> Cmd msg 18 | getIssues labels page f = Http.request 19 | { method = "GET" 20 | , headers = [] 21 | , url = "/issues?page=" ++ String.fromInt page 22 | , body = Http.jsonBody (E.list E.string labels) 23 | , expect = Http.expectJson f (D.list decodeIssue) 24 | , timeout = Nothing 25 | , tracker = Nothing 26 | } 27 | -------------------------------------------------------------------------------- /frontend/src/IW/Core/Encoder.elm: -------------------------------------------------------------------------------- 1 | module IW.Core.Encoder exposing (..) 2 | 3 | import Iso8601 as Iso 4 | import Json.Encode as E exposing (..) 5 | 6 | import IW.Core.ElmStreet exposing (..) 7 | import IW.Core.Types exposing (..) 8 | 9 | 10 | encodeIssue : Issue -> Value 11 | encodeIssue x = E.object 12 | [ ("repoOwner", E.string x.repoOwner) 13 | , ("repoName", E.string x.repoName) 14 | , ("number", E.int x.number) 15 | , ("title", E.string x.title) 16 | , ("body", E.string x.body) 17 | , ("labels", E.list E.string x.labels) 18 | ] 19 | 20 | encodeRepo : Repo -> Value 21 | encodeRepo x = E.object 22 | [ ("owner", E.string x.owner) 23 | , ("name", E.string x.name) 24 | , ("descr", E.string x.descr) 25 | , ("categories", E.list E.string x.categories) 26 | ] 27 | -------------------------------------------------------------------------------- /frontend/public/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 12 | 13 | Issue Wanted 14 | 15 | 16 | 19 |
20 | 21 | 22 | -------------------------------------------------------------------------------- /src/IW/Config.hs: -------------------------------------------------------------------------------- 1 | {- | Configurations through the @config.toml@ file@. 2 | -} 3 | 4 | module IW.Config 5 | ( Config (..) 6 | , configT 7 | , loadConfig 8 | ) where 9 | 10 | import Toml (TomlCodec, (.=)) 11 | import qualified Toml 12 | 13 | 14 | -- | Data type for the configurable elements of the application. 15 | data Config = Config 16 | { cDbCredentials :: !ByteString 17 | , cLogSeverity :: !Severity 18 | } 19 | 20 | -- | TOML codec for the 'Config' data type. 21 | configT :: TomlCodec Config 22 | configT = Config 23 | <$> Toml.byteString "dbCredentials" .= cDbCredentials 24 | <*> Toml.read "log.severity" .= cLogSeverity 25 | 26 | -- | Loads the @config.toml@ file. 27 | loadConfig :: MonadIO m => m Config 28 | loadConfig = Toml.decodeFile configT "config.toml" 29 | -------------------------------------------------------------------------------- /frontend/src/IW/Core/Decoder.elm: -------------------------------------------------------------------------------- 1 | module IW.Core.Decoder exposing (..) 2 | 3 | import Iso8601 as Iso 4 | import Json.Decode as D exposing (..) 5 | import Json.Decode.Pipeline as D exposing (required) 6 | 7 | import IW.Core.ElmStreet exposing (..) 8 | import IW.Core.Types exposing (..) 9 | 10 | 11 | decodeIssue : Decoder Issue 12 | decodeIssue = D.succeed Issue 13 | |> required "repoOwner" D.string 14 | |> required "repoName" D.string 15 | |> required "number" D.int 16 | |> required "title" D.string 17 | |> required "body" D.string 18 | |> required "labels" (D.list D.string) 19 | 20 | decodeRepo : Decoder Repo 21 | decodeRepo = D.succeed Repo 22 | |> required "owner" D.string 23 | |> required "name" D.string 24 | |> required "descr" D.string 25 | |> required "categories" (D.list D.string) 26 | -------------------------------------------------------------------------------- /src/IW/Server.hs: -------------------------------------------------------------------------------- 1 | module IW.Server 2 | ( IwApi 3 | , server 4 | ) where 5 | 6 | import Servant.API.Generic (toServant) 7 | import Servant.Server (Server, hoistServer) 8 | 9 | import IW.App (AppEnv) 10 | import IW.Effects.Log (runAppAsHandler) 11 | import IW.Server.Issue (IssuesApi, issuesHandler) 12 | import IW.Server.Repo (ReposApi, reposHandler) 13 | import IW.Server.Types (AppServer, ToApi) 14 | 15 | 16 | data IwSite route = IwSite 17 | { iwIssuesRoute :: route :- IssuesApi 18 | , iwReposRoute :: route :- ReposApi 19 | } deriving (Generic) 20 | 21 | type IwApi = ToApi IwSite 22 | 23 | iwServer :: IwSite AppServer 24 | iwServer = IwSite 25 | { iwIssuesRoute = issuesHandler 26 | , iwReposRoute = reposHandler 27 | } 28 | 29 | server :: AppEnv -> Server IwApi 30 | server env = hoistServer (Proxy @IwApi) (runAppAsHandler env) (toServant iwServer) 31 | -------------------------------------------------------------------------------- /src/IW/Db/Schema.hs: -------------------------------------------------------------------------------- 1 | -- | Helper functions to create and drop database from @.sql@ files. 2 | 3 | module IW.Db.Schema 4 | ( prepareDb 5 | ) where 6 | 7 | import IW.Db.Functions (WithDb, executeRaw) 8 | 9 | 10 | {- | Prepare data base for the testing environment: 11 | 1. Drop all existing tables. 12 | 2. Created tables from scratch. 13 | 3. Populate tables with test data. 14 | -} 15 | prepareDb :: (WithDb env m) => m () 16 | prepareDb = teardownDb >> setupDb 17 | 18 | -- | Create tables from the @sql/schema.sql@ file. 19 | setupDb :: (WithDb env m) => m () 20 | setupDb = executeFile "sql/schema.sql" 21 | 22 | -- | Create tables from the @sql/schema.sql@ file. 23 | teardownDb :: (WithDb env m) => m () 24 | teardownDb = executeFile "sql/drop.sql" 25 | 26 | executeFile :: (WithDb env m) => FilePath -> m () 27 | executeFile path = do 28 | sqlStatements <- readFile path 29 | executeRaw (fromString sqlStatements) 30 | -------------------------------------------------------------------------------- /src/IW/Core/Id.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} 2 | 3 | {-# LANGUAGE AllowAmbiguousTypes #-} 4 | 5 | module IW.Core.Id 6 | ( Id (..) 7 | , AnyId 8 | , castId 9 | ) where 10 | 11 | import Data.Type.Equality (type (==)) 12 | import Elm.Generic (elmNewtype) 13 | 14 | 15 | -- | Wrapper for integer id. Contains phantom type parameter for increased 16 | -- type-safety. 17 | newtype Id a = Id { unId :: Int } 18 | deriving stock (Generic, Show) 19 | deriving newtype (Eq, Ord, FromField, ToField, FromJSON, ToJSON, FromHttpApiData) 20 | 21 | instance Elm (Id a) where 22 | toElmDefinition _ = elmNewtype @Int "Id" "unId" 23 | 24 | -- | When we don't care about type of 'Id' but don't want to deal with type variables. 25 | type AnyId = Id () 26 | 27 | -- | Unsafe cast of 'Id'. Implementation uses smart trick to enforce usage 28 | -- always with @TypeApplications@. 29 | castId :: forall to from to' . ((to == to') ~ 'True) => Id from -> Id to' 30 | castId (Id a) = Id a 31 | -------------------------------------------------------------------------------- /src/IW/Core/WithId.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | 3 | {- | @WithId a@ provides an @Id a@ field to types that don't have one. This was added 4 | because types with an @Id a@ can be sorted and updated more effeciently. 5 | -} 6 | 7 | module IW.Core.WithId 8 | ( WithId (..) 9 | ) where 10 | 11 | import IW.Core.Id (Id (..)) 12 | 13 | import Database.PostgreSQL.Simple.FromRow (RowParser) 14 | import Database.PostgreSQL.Simple.ToField (Action) 15 | import Database.PostgreSQL.Simple.Types ((:.) (..)) 16 | 17 | 18 | data WithId a = WithId 19 | { withIdId :: !(Id a) 20 | , withIdVal :: !a 21 | } deriving stock (Generic, Show, Eq) 22 | deriving anyclass (ToJSON) 23 | 24 | instance FromRow a => FromRow (WithId a) where 25 | fromRow :: RowParser (WithId a) 26 | fromRow = WithId <$> field <*> fromRow 27 | {-# INLINE fromRow #-} 28 | 29 | instance ToRow a => ToRow (WithId a) where 30 | toRow :: WithId a -> [Action] 31 | toRow WithId{..} = toRow (Only withIdId :. withIdVal) 32 | {-# INLINE toRow #-} 33 | -------------------------------------------------------------------------------- /frontend/elm.json: -------------------------------------------------------------------------------- 1 | { 2 | "type": "application", 3 | "source-directories": [ 4 | "src" 5 | ], 6 | "elm-version": "0.19.0", 7 | "dependencies": { 8 | "direct": { 9 | "GlobalWebIndex/cmd-extra": "1.1.2", 10 | "NoRedInk/elm-json-decode-pipeline": "1.0.0", 11 | "elm/browser": "1.0.0", 12 | "elm/core": "1.0.2", 13 | "elm/html": "1.0.0", 14 | "elm/http": "2.0.0", 15 | "elm/json": "1.1.3", 16 | "elm/time": "1.0.0", 17 | "elm/url": "1.0.0", 18 | "rtfeldman/elm-iso8601-date-strings": "1.1.2" 19 | }, 20 | "indirect": { 21 | "elm/bytes": "1.0.8", 22 | "elm/file": "1.0.4", 23 | "elm/parser": "1.1.0", 24 | "elm/virtual-dom": "1.0.0" 25 | } 26 | }, 27 | "test-dependencies": { 28 | "direct": { 29 | "elm-explorations/test": "1.0.0" 30 | }, 31 | "indirect": { 32 | "elm/random": "1.0.0" 33 | } 34 | } 35 | } -------------------------------------------------------------------------------- /src/IW/Server/Issue.hs: -------------------------------------------------------------------------------- 1 | module IW.Server.Issue 2 | ( -- * API 3 | IssuesApi 4 | , issuesServer 5 | 6 | -- * Handlers 7 | , issuesHandler 8 | ) where 9 | 10 | import IW.App (WithError) 11 | import IW.Core.Issue (Issue (..), Label (..)) 12 | import IW.Core.WithId (WithId (..)) 13 | import IW.Db (WithDb, getIssuesByLabels) 14 | import IW.Server.Types (AppServer, ToApi) 15 | 16 | 17 | type IssuesApi = ToApi IssuesSite 18 | 19 | newtype IssuesSite route = IssuesSite 20 | { issuesRoute :: route 21 | :- "issues" 22 | :> ReqBody '[JSON] [Label] 23 | :> QueryParam "page" Int 24 | :> Get '[JSON] [WithId Issue] 25 | } deriving (Generic) 26 | 27 | issuesServer :: IssuesSite AppServer 28 | issuesServer = IssuesSite 29 | { issuesRoute = issuesHandler 30 | } 31 | 32 | issuesHandler 33 | :: ( WithDb env m 34 | , WithError m 35 | ) 36 | => [Label] 37 | -> Maybe Int 38 | -> m [WithId Issue] 39 | issuesHandler labels page = getIssuesByLabels labels $ fromMaybe 0 page 40 | -------------------------------------------------------------------------------- /src/IW/Server/Repo.hs: -------------------------------------------------------------------------------- 1 | module IW.Server.Repo 2 | ( -- * API 3 | ReposApi 4 | , reposServer 5 | 6 | -- * Handlers 7 | , reposHandler 8 | ) where 9 | 10 | import IW.App (WithError) 11 | import IW.Core.Repo (Repo (..), Category (..)) 12 | import IW.Core.WithId (WithId (..)) 13 | import IW.Db (WithDb, getReposByCategories) 14 | import IW.Server.Types (AppServer, ToApi) 15 | 16 | 17 | type ReposApi = ToApi ReposSite 18 | 19 | newtype ReposSite route = ReposSite 20 | { reposRoute :: route 21 | :- "repos" 22 | :> ReqBody '[JSON] [Category] 23 | :> QueryParam "page" Int 24 | :> Get '[JSON] [WithId Repo] 25 | } deriving (Generic) 26 | 27 | reposServer :: ReposSite AppServer 28 | reposServer = ReposSite 29 | { reposRoute = reposHandler 30 | } 31 | 32 | reposHandler 33 | :: ( WithDb env m 34 | , WithError m 35 | ) 36 | => [Category] 37 | -> Maybe Int 38 | -> m [WithId Repo] 39 | reposHandler categories page = getReposByCategories categories $ fromMaybe 0 page 40 | -------------------------------------------------------------------------------- /src/IW.hs: -------------------------------------------------------------------------------- 1 | module IW 2 | ( mkAppEnv 3 | , mkGhciEnv 4 | , runServer 5 | , main 6 | ) where 7 | 8 | import Network.HTTP.Client.TLS (newTlsManager) 9 | import Network.Wai.Handler.Warp (run) 10 | import Servant.Server (serve) 11 | 12 | import IW.App (AppEnv, Env (..)) 13 | import IW.Config (Config (..), loadConfig) 14 | import IW.Db (initialisePool) 15 | import IW.Effects.Log (mainLogAction) 16 | import IW.Server (IwApi, server) 17 | 18 | 19 | mkAppEnv :: Config -> IO AppEnv 20 | mkAppEnv Config{..} = do 21 | -- IO configuration 22 | envDbPool <- initialisePool cDbCredentials 23 | 24 | -- Http manager configuration 25 | envManager <- newTlsManager 26 | 27 | -- pure configuration 28 | let envLogAction = mainLogAction cLogSeverity 29 | pure Env{..} 30 | 31 | mkGhciEnv :: IO AppEnv 32 | mkGhciEnv = loadConfig >>= mkAppEnv 33 | 34 | runServer :: AppEnv -> IO () 35 | runServer env@Env{..} = run 8080 application 36 | where 37 | application = serve (Proxy @IwApi) (server env) 38 | 39 | main :: IO () 40 | main = loadConfig >>= mkAppEnv >>= runServer 41 | -------------------------------------------------------------------------------- /sql/seed.sql: -------------------------------------------------------------------------------- 1 | -- To execute this file from SQL REPL: 2 | -- \i sql/seed.sql 3 | 4 | ------------- 5 | -- UPSERTS -- 6 | ------------- 7 | 8 | /* 9 | INSERT INTO repos 10 | (owner, name, descr, categories) 11 | VALUES 12 | ('owner123', 'repo123', 'A test repo.', ARRAY['Testing']) 13 | ON CONFLICT ON CONSTRAINT unique_repos DO 14 | UPDATE SET 15 | descr = EXCLUDED.descr 16 | , categories = EXCLUDED.categories; 17 | */ 18 | 19 | /* 20 | INSERT INTO issues 21 | (repo_owner, repo_name, number, title, body, labels) 22 | SELECT 23 | repo_owner, repo_name, number, title, body, labels 24 | FROM ( VALUES 25 | ('owner123', 'repo123', 123, 'This is a test issue', 'Use this issue for testing.', ARRAY['good first issue']) 26 | ) 27 | AS new (repo_owner, repo_name, number, title, body, labels) 28 | WHERE EXISTS ( 29 | SELECT (owner, name) 30 | FROM repos 31 | WHERE (repos.owner, repos.name) = (new.repo_owner, new.repo_name) 32 | ) 33 | ON CONFLICT ON CONSTRAINT unique_issues DO 34 | UPDATE SET 35 | title = EXCLUDED.title 36 | , body = EXCLUDED.body 37 | , labels = EXCLUDED.labels; 38 | */ 39 | -------------------------------------------------------------------------------- /src/IW/Core/Issue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | 3 | module IW.Core.Issue 4 | ( Issue (..) 5 | , Label (..) 6 | , issueUrl 7 | ) where 8 | 9 | import IW.Core.SqlArray (SqlArray (..)) 10 | import IW.Core.Repo (RepoName (..), RepoOwner (..)) 11 | import IW.Core.Url (Url (..)) 12 | 13 | import qualified Data.Text as T 14 | 15 | 16 | -- | Wrapper for issue label names. 17 | newtype Label = Label { unLabel :: Text } 18 | deriving stock (Generic, Show) 19 | deriving newtype (Eq, Ord, FromField, ToField, FromJSON, ToJSON, Elm, FromHttpApiData) 20 | 21 | -- | Data type representing a GitHub issue. 22 | data Issue = Issue 23 | { issueRepoOwner :: !RepoOwner 24 | , issueRepoName :: !RepoName 25 | , issueNumber :: !Int 26 | , issueTitle :: !Text 27 | , issueBody :: !Text 28 | , issueLabels :: !(SqlArray Label) 29 | } deriving stock (Eq, Generic, Show) 30 | deriving anyclass (FromRow, ToRow) 31 | deriving (Elm, ToJSON) via ElmStreet Issue 32 | 33 | issueUrl :: Issue -> Url 34 | issueUrl Issue{..} = Url $ T.intercalate "/" 35 | [ "https://github.com" 36 | , unRepoOwner issueRepoOwner 37 | , unRepoName issueRepoName 38 | , "issues" 39 | , show issueNumber 40 | ] 41 | -------------------------------------------------------------------------------- /src/IW/App/Env.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE TypeSynonymInstances #-} 3 | 4 | module IW.App.Env 5 | ( Env (..) 6 | , Has (..) 7 | , grab 8 | , DbPool 9 | ) where 10 | 11 | import Colog (HasLog (..), Message, LogAction) 12 | import Data.Pool (Pool) 13 | import Database.PostgreSQL.Simple (Connection) 14 | import Network.HTTP.Client (Manager) 15 | 16 | 17 | type DbPool = Pool Connection 18 | 19 | data Env (m :: Type -> Type) = Env 20 | { envDbPool :: !DbPool 21 | , envManager :: !Manager 22 | , envLogAction :: !(LogAction m Message) 23 | } 24 | 25 | instance HasLog (Env m) Message m where 26 | getLogAction :: Env m -> LogAction m Message 27 | getLogAction = envLogAction 28 | 29 | setLogAction :: LogAction m Message -> Env m -> Env m 30 | setLogAction newAction env = env { envLogAction = newAction } 31 | 32 | class Has field env where 33 | obtain :: env -> field 34 | 35 | instance Has DbPool (Env m) where obtain = envDbPool 36 | instance Has Manager (Env m) where obtain = envManager 37 | instance Has (LogAction m Message) (Env m) where obtain = envLogAction 38 | 39 | grab :: forall field env m . (MonadReader env m, Has field env) => m field 40 | grab = asks $ obtain @field 41 | -------------------------------------------------------------------------------- /src/IW/Core/Repo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | 3 | module IW.Core.Repo 4 | ( Repo (..) 5 | , RepoOwner (..) 6 | , RepoName (..) 7 | , Category (..) 8 | ) where 9 | 10 | import IW.Core.SqlArray (SqlArray (..)) 11 | import IW.Core.Url (Url) 12 | 13 | 14 | -- | Wrapper for a repository owner. 15 | newtype RepoOwner = RepoOwner { unRepoOwner :: Text } 16 | deriving stock (Generic, Show) 17 | deriving newtype (Eq, Ord, FromField, ToField, ToJSON, Elm, FromHttpApiData) 18 | 19 | -- | Wrapper for a repository name. 20 | newtype RepoName = RepoName { unRepoName :: Text } 21 | deriving stock (Generic, Show) 22 | deriving newtype (Eq, Ord, FromField, ToField, ToJSON, Elm, FromHttpApiData) 23 | 24 | -- | Wrapper for repository Hackage category names. 25 | newtype Category = Category { unCategory :: Text } 26 | deriving stock (Generic, Show) 27 | deriving newtype (Eq, Ord, FromField, ToField, FromJSON, ToJSON, Elm, FromHttpApiData) 28 | 29 | -- | Data type representing a GitHub repository. 30 | data Repo = Repo 31 | { repoOwner :: !RepoOwner 32 | , repoName :: !RepoName 33 | , repoDescr :: !Text 34 | , repoCategories :: !(SqlArray Category) 35 | , repoCabalUrl :: !Url 36 | } deriving stock (Eq, Generic, Show) 37 | deriving anyclass (FromRow, ToRow) 38 | deriving (Elm, ToJSON) via ElmStreet Repo 39 | -------------------------------------------------------------------------------- /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | 3 | jobs: 4 | backend: 5 | docker: 6 | - image: kowainik/haskell-ci 7 | - image: circleci/postgres:10-alpine-ram 8 | environment: 9 | POSTGRES_USER: root 10 | POSTGRES_DB: issue-wanted 11 | steps: 12 | - checkout 13 | - restore-cache: 14 | key: stack-{{ checksum "stack.yaml" }} 15 | - run: curl https://raw.githubusercontent.com/kowainik/relude/55968311244690f5cc8b4484a37a63d988ea2ec4/.hlint.yaml -o .hlint-relude.yaml 16 | - run: curl -sSL https://raw.github.com/ndmitchell/neil/master/misc/travis.sh | sh -s -- hlint -h .hlint-relude.yaml . 17 | - run: stack build -j1 --fast --test --no-run-tests 18 | - run: stack test --fast 19 | - save_cache: 20 | key: stack-{{ checksum "stack.yaml" }} 21 | paths: 22 | - "~/.stack" 23 | - ".stack-work" 24 | 25 | frontend: 26 | docker: 27 | - image: holmusk/elm-ci 28 | steps: 29 | - checkout 30 | - restore_cache: 31 | key: node-modules-{{ checksum "frontend/elm.json" }} 32 | - run: cd frontend && npm install && elm-app build 33 | - save_cache: 34 | key: node-modules-{{ checksum "frontend/elm.json" }} 35 | paths: 36 | - "frontend/node_modules" 37 | 38 | workflows: 39 | version: 2 40 | build: 41 | jobs: 42 | - backend 43 | - frontend 44 | -------------------------------------------------------------------------------- /frontend/src/IW/Core/ElmStreet.elm: -------------------------------------------------------------------------------- 1 | module IW.Core.ElmStreet exposing (..) 2 | 3 | import Json.Encode as E exposing (Value) 4 | import Json.Decode as D exposing (Decoder) 5 | import Json.Decode.Pipeline as D exposing (..) 6 | 7 | 8 | elmStreetEncodeMaybe : (a -> Value) -> Maybe a -> Value 9 | elmStreetEncodeMaybe enc = Maybe.withDefault E.null << Maybe.map enc 10 | 11 | elmStreetEncodeEither : (a -> Value) -> (b -> Value) -> Result a b -> Value 12 | elmStreetEncodeEither encA encB res = E.object <| case res of 13 | Err a -> [("Left", encA a)] 14 | Ok b -> [("Right", encB b)] 15 | 16 | elmStreetEncodePair : (a -> Value) -> (b -> Value) -> (a, b) -> Value 17 | elmStreetEncodePair encA encB (a, b) = E.list identity [encA a, encB b] 18 | 19 | decodeStr : (String -> Maybe a) -> String -> Decoder a 20 | decodeStr readX x = case readX x of 21 | Just a -> D.succeed a 22 | Nothing -> D.fail "Constructor not matched" 23 | 24 | elmStreetDecodeEnum : (String -> Maybe a) -> Decoder a 25 | elmStreetDecodeEnum r = D.andThen (decodeStr r) D.string 26 | 27 | elmStreetDecodeChar : Decoder Char 28 | elmStreetDecodeChar = D.andThen (decodeStr (Maybe.map Tuple.first << String.uncons)) D.string 29 | 30 | elmStreetDecodeEither : Decoder a -> Decoder b -> Decoder (Result a b) 31 | elmStreetDecodeEither decA decB = D.oneOf 32 | [ D.field "Left" (D.map Err decA) 33 | , D.field "Right" (D.map Ok decB) 34 | ] 35 | 36 | elmStreetDecodePair : Decoder a -> Decoder b -> Decoder (a, b) 37 | elmStreetDecodePair decA decB = D.map2 Tuple.pair (D.index 0 decA) (D.index 1 decB) 38 | 39 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Exception (bracket) 4 | import Hedgehog (Group (..), checkParallel) 5 | import System.IO (hSetEncoding, utf8) 6 | import Test.Hspec (Spec, hspec) 7 | import Test.Hspec.Core.Spec (sequential) 8 | 9 | import IW (mkAppEnv) 10 | import IW.App (AppEnv, Env (..)) 11 | import IW.Config (loadConfig) 12 | import IW.Db (prepareDb) 13 | import IW.Effects.Log (runAppLogIO_) 14 | import Test.Common (joinSpecs) 15 | import Test.Core.Issue (issueRoundtripProp) 16 | import Test.Core.Repo (repoRoundtripProp) 17 | import Test.Db (dbSpecs) 18 | import Test.Sync (syncSpecs) 19 | 20 | import qualified Data.Pool as Pool 21 | 22 | 23 | hspecTests :: AppEnv -> Spec 24 | hspecTests = sequential . joinSpecs "issue-wanted" 25 | [ dbSpecs 26 | , syncSpecs 27 | ] 28 | 29 | hedgehogTests :: AppEnv -> Group 30 | hedgehogTests env = Group "Roundtrip properties" 31 | [ issueRoundtripProp env `named` "Issue: fromRow . toRow ≡ id" 32 | , repoRoundtripProp env `named` "Repo: fromRow . toRow ≡ id" 33 | ] 34 | where 35 | named :: a -> b -> (b, a) 36 | named = flip (,) 37 | 38 | main :: IO () 39 | main = bracket 40 | (loadConfig >>= mkAppEnv) 41 | (\Env{..} -> Pool.destroyAllResources envDbPool) 42 | runTests 43 | where 44 | runTests :: AppEnv -> IO () 45 | runTests env = do 46 | -- fix terminal encoding 47 | hSetEncoding stdout utf8 48 | hSetEncoding stderr utf8 49 | 50 | -- setup DB tables 51 | runAppLogIO_ env prepareDb 52 | 53 | -- run all tests 54 | hspec $ hspecTests env 55 | ifM (checkParallel $ hedgehogTests env) exitSuccess exitFailure 56 | -------------------------------------------------------------------------------- /src/IW/Sync/Update.hs: -------------------------------------------------------------------------------- 1 | {- | This module contains functions that are used for updating the database. 2 | It combines functionality from @IW.Sync.Search@ and @IW.Db@ to fetch the latest 3 | data and insert it into the database. 4 | -} 5 | 6 | module IW.Sync.Update 7 | ( syncRepos 8 | ) where 9 | 10 | import Control.Monad.IO.Unlift (MonadUnliftIO) 11 | import UnliftIO.Async (mapConcurrently_) 12 | 13 | import IW.App (WithError) 14 | import IW.Core.Repo (Repo (..)) 15 | import IW.Db (WithDb, upsertRepos, updateRepoCategories) 16 | import IW.Effects.Cabal (MonadCabal (..), getCabalCategories) 17 | import IW.Sync.Search (searchAllHaskellRepos) 18 | import IW.Time (getToday) 19 | 20 | 21 | -- | This function fetches all repos from the GitHub API, downloads their @.cabal@ files, 22 | -- and upserts them into the database. 23 | syncRepos 24 | :: forall env m. 25 | ( MonadCabal m 26 | , MonadUnliftIO m 27 | , WithDb env m 28 | , WithLog env m 29 | , WithError m 30 | ) 31 | => Integer -- ^ The starting date interval used in the search function 32 | -> m () 33 | syncRepos interval = do 34 | today <- liftIO getToday 35 | repos <- searchAllHaskellRepos today interval 36 | upsertRepos repos 37 | mapConcurrently_ syncCategories repos 38 | 39 | -- | This function takes a @Repo@ and attempts to download its @.cabal@ file. 40 | syncCategories 41 | :: forall env m. 42 | ( MonadCabal m 43 | , MonadUnliftIO m 44 | , WithDb env m 45 | , WithLog env m 46 | , WithError m 47 | ) 48 | => Repo 49 | -> m () 50 | syncCategories repo = do 51 | categories <- getCabalCategories repo 52 | updateRepoCategories repo categories 53 | -------------------------------------------------------------------------------- /src/Prelude.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | 3 | -- | Uses [relude](https://hackage.haskell.org/package/relude) as default Prelude. 4 | 5 | module Prelude 6 | ( module Relude 7 | , module Colog 8 | , module Control.Lens 9 | , module Elm 10 | , module Json 11 | , module Sql 12 | , module Web 13 | 14 | , WithLog 15 | , typeName 16 | ) where 17 | 18 | -- Reexport 19 | import Relude 20 | import Relude.Extra.Type (typeName) 21 | 22 | import Control.Lens ((.~), (^.)) 23 | 24 | import Colog (pattern D, pattern E, pattern I, LogAction (..), Severity (..), pattern W, log) 25 | 26 | import Elm (Elm (..), ElmStreet (..), elmStreetParseJson, elmStreetToJson) 27 | 28 | import Data.Aeson as Json (FromJSON (parseJSON), ToJSON (toJSON)) 29 | 30 | import Database.PostgreSQL.Simple.FromField as Sql (FromField (fromField)) 31 | import Database.PostgreSQL.Simple.FromRow as Sql (FromRow (fromRow), field) 32 | import Database.PostgreSQL.Simple.SqlQQ as Sql (sql) 33 | import Database.PostgreSQL.Simple.ToField as Sql (ToField (toField)) 34 | import Database.PostgreSQL.Simple.ToRow as Sql (ToRow (toRow)) 35 | import Database.PostgreSQL.Simple.Types as Sql (Only (..)) 36 | import PgNamed as Sql ((=?)) 37 | 38 | import Servant.API as Web ((:>), Capture, Get, Header, Header', JSON, NoContent (NoContent), Post, 39 | QueryFlag, QueryParam, QueryParam', ReqBody) 40 | import Servant.API.Generic as Web ((:-), toServant) 41 | import Web.HttpApiData as Web (FromHttpApiData (..), ToHttpApiData (..)) 42 | 43 | -- Internal 44 | import qualified Colog (Message, WithLog) 45 | 46 | 47 | -- | 'Colog.WithLog' alias specialized to 'Message' data type. 48 | type WithLog env m = Colog.WithLog env Colog.Message m 49 | -------------------------------------------------------------------------------- /src/IW/App/Monad.hs: -------------------------------------------------------------------------------- 1 | module IW.App.Monad 2 | ( -- * Application monad 3 | App (..) 4 | , AppEnv 5 | , runAppAsIO 6 | ) where 7 | 8 | import Control.Exception (catch, throwIO, try) 9 | import Control.Monad.Except (MonadError (..)) 10 | import Control.Monad.IO.Unlift (MonadUnliftIO (..)) 11 | import Relude.Extra.Bifunctor (firstF) 12 | 13 | import IW.App.Env (Env) 14 | import IW.App.Error (AppError, AppException (..)) 15 | 16 | 17 | -- | 'Env' data type parameterized by 'App' monad 18 | type AppEnv = Env App 19 | 20 | -- | Main application monad. 21 | newtype App a = App 22 | { unApp :: ReaderT AppEnv IO a 23 | } deriving (Functor, Applicative, Monad, MonadIO, MonadReader AppEnv, MonadUnliftIO) 24 | 25 | instance MonadError AppError App where 26 | throwError :: AppError -> App a 27 | throwError = liftIO . throwIO . AppException 28 | {-# INLINE throwError #-} 29 | 30 | catchError :: App a -> (AppError -> App a) -> App a 31 | catchError action handler = App $ ReaderT $ \env -> do 32 | let ioAction = runApp env action 33 | ioAction `catch` \(AppException e) -> runApp env $ handler e 34 | {-# INLINE catchError #-} 35 | 36 | {- | Helper for running route handlers in IO. Catches exception of type 37 | 'AppException' and unwraps 'AppError' from it. 38 | Do not use this function to run the application. Use runners with logging from 39 | "Lib.Effects.Log" module to also log the error. 40 | -} 41 | runAppAsIO :: AppEnv -> App a -> IO (Either AppError a) 42 | runAppAsIO env = firstF unAppException . try . runApp env 43 | 44 | {- | Helper for running 'App'. 45 | Do not use this function to run the application. Use runners with logging from 46 | "Lib.Effects.Log" module to also log the error. 47 | -} 48 | runApp :: AppEnv -> App a -> IO a 49 | runApp env = usingReaderT env . unApp 50 | -------------------------------------------------------------------------------- /test/Test/Core/Repo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | module Test.Core.Repo 4 | ( repoRoundtripProp 5 | ) where 6 | 7 | import Hedgehog (MonadGen, Property, forAll, property, (===)) 8 | 9 | import IW.App (AppEnv, WithError) 10 | import IW.Core.Repo (Repo (..), Category (..)) 11 | import IW.Core.SqlArray (SqlArray (..)) 12 | import IW.Core.WithId (WithId (..)) 13 | import IW.Effects.Log (runAppLogIO) 14 | import IW.Db (WithDb) 15 | import IW.Db.Functions (asSingleRow, query) 16 | import IW.Sync.Search (mkRepoCabalUrl) 17 | import Test.Gen (genId, genRepoOwner, genRepoName) 18 | 19 | import qualified Hedgehog.Gen as Gen 20 | import qualified Hedgehog.Range as Range 21 | 22 | 23 | repoViaSql :: (WithDb env m, WithError m) => WithId Repo -> m (WithId Repo) 24 | repoViaSql = asSingleRow . query [sql| SELECT ?, ?, ?, ?, (? :: TEXT ARRAY), ? |] 25 | 26 | repoRoundtripProp :: AppEnv -> Property 27 | repoRoundtripProp env = property $ do 28 | generatedRepo <- forAll genRepo 29 | parsedRepo <- liftIO $ runAppLogIO env $ repoViaSql generatedRepo 30 | parsedRepo === Right generatedRepo 31 | 32 | testCategories :: [Category] 33 | testCategories = Category <$> 34 | [ "FFI" 35 | , "Text" 36 | , "Database" 37 | , "JSON" 38 | , "Concurrency" 39 | ] 40 | 41 | genRepo :: MonadGen m => m (WithId Repo) 42 | genRepo = do 43 | repoId <- genId 44 | repoOwner <- genRepoOwner 45 | repoName <- genRepoName 46 | repoDescr <- genDescr 47 | repoCategories <- genCategories 48 | let repoCabalUrl = mkRepoCabalUrl repoOwner repoName Nothing 49 | 50 | pure $ WithId repoId Repo{..} 51 | where 52 | genDescr :: MonadGen m => m Text 53 | genDescr = Gen.text (Range.constant 0 300) Gen.alphaNum 54 | 55 | genCategories :: MonadGen m => m (SqlArray Category) 56 | genCategories = SqlArray <$> Gen.subsequence testCategories 57 | -------------------------------------------------------------------------------- /sql/schema.sql: -------------------------------------------------------------------------------- 1 | -- To execute this file from SQL REPL: 2 | -- \i sql/schema.sql 3 | 4 | ----------------- 5 | -- BASE TABLES -- 6 | ----------------- 7 | 8 | CREATE TABLE IF NOT EXISTS repos 9 | ( id SERIAL PRIMARY KEY 10 | , owner TEXT NOT NULL 11 | , name TEXT NOT NULL 12 | , descr TEXT NOT NULL 13 | , categories TEXT ARRAY NOT NULL 14 | , cabal_url TEXT NOT NULL 15 | , created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL 16 | , updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL 17 | ); 18 | 19 | CREATE TABLE IF NOT EXISTS issues 20 | ( id SERIAL PRIMARY KEY 21 | , repo_owner TEXT NOT NULL 22 | , repo_name TEXT NOT NULL 23 | , number INT NOT NULL 24 | , title TEXT NOT NULL 25 | , body TEXT NOT NULL 26 | , labels TEXT ARRAY NOT NULL 27 | , created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL 28 | , updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL 29 | ); 30 | 31 | ----------------------------- 32 | -- FOREIGN KEY CONSTRAINTS -- 33 | ----------------------------- 34 | 35 | ALTER TABLE ONLY repos 36 | ADD CONSTRAINT unique_repos UNIQUE (owner, name); 37 | 38 | ALTER TABLE ONLY issues 39 | ADD CONSTRAINT unique_issues UNIQUE (repo_owner, repo_name, number); 40 | 41 | ALTER TABLE ONLY issues 42 | ADD CONSTRAINT fk_repos FOREIGN KEY (repo_owner, repo_name) 43 | REFERENCES repos (owner, name) ON DELETE CASCADE; 44 | 45 | -------------- 46 | -- TRIGGERS -- 47 | -------------- 48 | 49 | CREATE OR REPLACE FUNCTION update_updated_at() 50 | RETURNS TRIGGER AS $$ 51 | BEGIN 52 | NEW.updated_at = NOW(); 53 | RETURN NEW; 54 | END; 55 | $$ LANGUAGE 'plpgsql'; 56 | 57 | CREATE TRIGGER update_updated_at_repos BEFORE UPDATE ON repos FOR EACH ROW EXECUTE PROCEDURE update_updated_at(); 58 | CREATE TRIGGER update_updated_at_issues BEFORE UPDATE ON issues FOR EACH ROW EXECUTE PROCEDURE update_updated_at(); 59 | -------------------------------------------------------------------------------- /src/IW/Effects/Log.hs: -------------------------------------------------------------------------------- 1 | -- | Logging action for the project. Currently just logs the output to terminal. 2 | 3 | module IW.Effects.Log 4 | ( mainLogAction 5 | 6 | , runAppAsHandler 7 | , runAppLogIO 8 | , runAppLogIO_ 9 | ) where 10 | 11 | import Colog (LogAction, Message, Msg (..), Severity, filterBySeverity, richMessageAction) 12 | import Control.Monad.Except (liftEither) 13 | import Servant.Server (Handler) 14 | 15 | import IW.App (App, AppEnv, AppError, runAppAsIO, toHttpError) 16 | 17 | 18 | -- | Maing log action for the application. Prints message with some metadata to @stdout@. 19 | mainLogAction :: MonadIO m => Severity -> LogAction m Message 20 | mainLogAction severity = 21 | filterBySeverity severity msgSeverity richMessageAction 22 | 23 | ---------------------------------------------------------------------------- 24 | -- Application runners with runners 25 | ---------------------------------------------------------------------------- 26 | 27 | -- | Runs application as servant 'Handler'. 28 | runAppAsHandler :: AppEnv -> App a -> Handler a 29 | runAppAsHandler env app = do 30 | res <- liftIO $ runAppLogIO env app 31 | liftEither $ first toHttpError res 32 | 33 | -- | Runs application like 'runAppAsIO' but also logs error. 34 | runAppLogIO :: AppEnv -> App a -> IO (Either AppError a) 35 | runAppLogIO env app = do 36 | appRes <- runAppAsIO env app 37 | logRes <- whenLeft (Right ()) appRes (logMPErrorIO env) 38 | pure $ appRes <* logRes 39 | 40 | -- | Like 'runAppAsIO' but discards result. 41 | runAppLogIO_ :: AppEnv -> App a -> IO () 42 | runAppLogIO_ env app = void $ runAppLogIO env app 43 | 44 | ---------------------------------------------------------------------------- 45 | -- Internal utilities 46 | ---------------------------------------------------------------------------- 47 | 48 | logMPErrorIO :: AppEnv -> AppError -> IO (Either AppError ()) 49 | logMPErrorIO env err = runAppAsIO env $ log E $ show err 50 | -------------------------------------------------------------------------------- /src/IW/Db/Issue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | -- | SQL queries to work with the @issues@ table. 4 | 5 | module IW.Db.Issue 6 | ( getIssues 7 | , getIssuesByLabels 8 | , upsertIssues 9 | ) where 10 | 11 | import IW.App (WithError) 12 | import IW.Core.Issue (Issue (..), Label (..)) 13 | import IW.Core.SqlArray (SqlArray (..)) 14 | import IW.Core.WithId (WithId) 15 | import IW.Db.Functions (WithDb, executeMany, queryNamed) 16 | 17 | 18 | -- | Returns all issues in the database. 19 | getIssues :: (WithDb env m, WithError m) => Int -> m [WithId Issue] 20 | getIssues page = queryNamed [sql| 21 | SELECT id, repo_owner, repo_name, number, title, body, labels 22 | FROM issues 23 | LIMIT 100 24 | OFFSET (?page * 100) 25 | |] [ "page" =? page ] 26 | 27 | -- | Returns all issues with at least one label in the given list. 28 | getIssuesByLabels :: (WithDb env m, WithError m) => [Label] -> Int -> m [WithId Issue] 29 | getIssuesByLabels labels page = queryNamed [sql| 30 | SELECT id, repo_owner, repo_name, number, title, body, labels 31 | FROM issues 32 | WHERE labels && ?labels 33 | LIMIT 100 34 | OFFSET (?page * 100) 35 | |] [ "labels" =? SqlArray labels 36 | , "page" =? page 37 | ] 38 | 39 | -- | Insert a list of issues into the database, but update on conflict. 40 | upsertIssues :: (WithDb env m) => [Issue] -> m () 41 | upsertIssues = executeMany [sql| 42 | INSERT INTO issues 43 | (repo_owner, repo_name, number, title, body, labels) 44 | SELECT 45 | repo_owner, repo_name, number, title, body, labels 46 | FROM (VALUES (?, ?, ?, ?, ?, ?)) AS 47 | new (repo_owner, repo_name, number, title, body, labels) 48 | WHERE EXISTS ( 49 | SELECT (owner, name) 50 | FROM repos 51 | WHERE (repos.owner, repos.name) = (new.repo_owner, new.repo_name) 52 | ) 53 | ON CONFLICT ON CONSTRAINT unique_issues DO 54 | UPDATE SET 55 | title = EXCLUDED.title 56 | , body = EXCLUDED.body 57 | , labels = EXCLUDED.labels; 58 | |] 59 | -------------------------------------------------------------------------------- /test/Test/Core/Issue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | module Test.Core.Issue 4 | ( issueRoundtripProp 5 | ) where 6 | 7 | import Hedgehog (MonadGen, Property, forAll, property, (===)) 8 | 9 | import IW.App (AppEnv, WithError) 10 | import IW.Core.Issue (Issue (..), Label (..)) 11 | import IW.Core.SqlArray (SqlArray (..)) 12 | import IW.Core.WithId (WithId (..)) 13 | import IW.Effects.Log (runAppLogIO) 14 | import IW.Db (WithDb) 15 | import IW.Db.Functions (asSingleRow, query) 16 | import Test.Gen (genId, genRepoOwner, genRepoName) 17 | 18 | import qualified Hedgehog.Gen as Gen 19 | import qualified Hedgehog.Range as Range 20 | 21 | 22 | issueViaSql :: (WithDb env m, WithError m) => WithId Issue -> m (WithId Issue) 23 | issueViaSql = asSingleRow . query [sql| SELECT ?, ?, ?, ?, ?, ?, (? :: TEXT ARRAY) |] 24 | 25 | issueRoundtripProp :: AppEnv -> Property 26 | issueRoundtripProp env = property $ do 27 | generatedIssue <- forAll genIssue 28 | parsedIssue <- liftIO $ runAppLogIO env $ issueViaSql generatedIssue 29 | parsedIssue === Right generatedIssue 30 | 31 | testLabels :: [Label] 32 | testLabels = Label <$> 33 | [ "good first issue" 34 | , "help wanted" 35 | , "low hanging fruit" 36 | , "docs" 37 | , "easy" 38 | ] 39 | 40 | genIssue :: MonadGen m => m (WithId Issue) 41 | genIssue = do 42 | issueId <- genId 43 | issueRepoOwner <- genRepoOwner 44 | issueRepoName <- genRepoName 45 | issueNumber <- genNumber 46 | issueTitle <- genTitle 47 | issueBody <- genBody 48 | issueLabels <- genLabels 49 | 50 | pure $ WithId issueId Issue{..} 51 | where 52 | genNumber :: MonadGen m => m Int 53 | genNumber = Gen.int (Range.constant 1 500) 54 | 55 | genTitle :: MonadGen m => m Text 56 | genTitle = Gen.text (Range.constant 1 30) Gen.alphaNum 57 | 58 | genBody :: MonadGen m => m Text 59 | genBody = Gen.text (Range.constant 0 50) Gen.alphaNum 60 | 61 | genLabels :: MonadGen m => m (SqlArray Label) 62 | genLabels = SqlArray <$> Gen.subsequence testLabels 63 | -------------------------------------------------------------------------------- /src/IW/Db/Repo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | -- | SQL queries to work with the @repos@ table. 4 | 5 | module IW.Db.Repo 6 | ( getRepos 7 | , getReposByCategories 8 | , upsertRepos 9 | , updateRepoCategories 10 | ) where 11 | 12 | import IW.App (WithError) 13 | import IW.Core.Repo (Repo (..), Category) 14 | import IW.Core.SqlArray (SqlArray (..)) 15 | import IW.Core.WithId (WithId) 16 | import IW.Db.Functions (WithDb, executeMany, executeNamed, queryNamed) 17 | 18 | 19 | -- | Returns all repos in the database. 20 | getRepos :: (WithDb env m, WithError m) => Int -> m [WithId Repo] 21 | getRepos page = queryNamed [sql| 22 | SELECT id, owner, name, descr, categories, cabal_url 23 | FROM repos 24 | LIMIT 100 25 | OFFSET (?page * 100) 26 | |] [ "page" =? page ] 27 | 28 | -- | Returns all repos with at least one category in the given list. 29 | getReposByCategories :: (WithDb env m, WithError m) => [Category] -> Int -> m [WithId Repo] 30 | getReposByCategories categories page = queryNamed [sql| 31 | SELECT id, owner, name, descr, categories, cabal_url 32 | FROM repos 33 | WHERE categories && ?categories 34 | LIMIT 100 35 | OFFSET (?page * 100) 36 | |] [ "categories" =? SqlArray categories 37 | , "page" =? page 38 | ] 39 | 40 | -- | Insert a list of repos into the database, but update on conflict. 41 | upsertRepos :: WithDb env m => [Repo] -> m () 42 | upsertRepos = executeMany [sql| 43 | INSERT INTO repos 44 | (owner, name, descr, categories, cabal_url) 45 | VALUES 46 | (?, ?, ?, ?, ?) 47 | ON CONFLICT ON CONSTRAINT unique_repos DO 48 | UPDATE SET 49 | descr = EXCLUDED.descr 50 | , categories = EXCLUDED.categories; 51 | |] 52 | 53 | -- | Update a repo's categories field. 54 | updateRepoCategories 55 | :: ( WithDb env m 56 | , WithError m 57 | ) 58 | => Repo 59 | -> [Category] 60 | -> m () 61 | updateRepoCategories Repo{..} categories = void $ executeNamed [sql| 62 | UPDATE repos 63 | SET categories = ?categories 64 | WHERE owner = ?owner 65 | AND name = ?name 66 | |] [ "categories" =? SqlArray categories 67 | , "owner" =? repoOwner 68 | , "name" =? repoName 69 | ] 70 | -------------------------------------------------------------------------------- /src/IW/Effects/Download.hs: -------------------------------------------------------------------------------- 1 | {- | This module contains the class definitiion of @MonadDownload@ and 2 | an instance of @MonadDownload@ for the @App@ monad. Instances of 3 | @MonadDownload@ have a @downloadFile@ action for downloading files from a given URL. 4 | -} 5 | 6 | module IW.Effects.Download 7 | ( MonadDownload (..) 8 | , downloadFileMaybe 9 | 10 | -- * Internals 11 | , downloadFileImpl 12 | ) where 13 | 14 | import Network.HTTP.Client (Manager, Response (..), httpLbs) 15 | import Network.HTTP.Types (Status (..)) 16 | 17 | import IW.App (App, AppErrorType (..), Has, WithError, grab, throwError, catchError) 18 | import IW.Core.Url (Url (..)) 19 | 20 | 21 | -- | Describes a monad that can download files from a given @Url@. 22 | class Monad m => MonadDownload m where 23 | downloadFile :: Url -> m ByteString 24 | 25 | instance MonadDownload App where 26 | downloadFile = downloadFileImpl 27 | 28 | type WithDownload env m = (MonadIO m, MonadReader env m, WithError m, WithLog env m, Has Manager env) 29 | 30 | {- | This function takes an 'Url' and either returns a 'ByteString' representing 31 | the file contents, or throws an 'UrlDownloadFailed' error. 32 | -} 33 | downloadFileImpl :: WithDownload env m => Url -> m ByteString 34 | downloadFileImpl url@Url{..} = do 35 | man <- grab @Manager 36 | let req = fromString $ toString unUrl 37 | log D $ "Attempting to download file from " <> unUrl <> " ..." 38 | response <- liftIO $ httpLbs req man 39 | let status = statusCode $ responseStatus response 40 | let body = responseBody response 41 | log D $ "Recieved a status code of " <> show status <> " from " <> unUrl 42 | case status of 43 | 200 -> do 44 | log I $ "Successfully downloaded file from " <> unUrl 45 | pure $ toStrict body 46 | _ -> do 47 | log E $ "Couldn't download file from " <> unUrl 48 | throwError $ UrlDownloadFailed url 49 | 50 | -- | A verison of 'downloadFile' that returns a @'Maybe' 'ByteString'@, 51 | downloadFileMaybe :: (MonadDownload m, WithError m) => Url -> m (Maybe ByteString) 52 | downloadFileMaybe url = (Just <$> downloadFile url) `catchError` \case 53 | UrlDownloadFailed _ -> pure Nothing 54 | err -> throwError err 55 | -------------------------------------------------------------------------------- /test/Test/Data.hs: -------------------------------------------------------------------------------- 1 | module Test.Data 2 | ( -- * Issue 3 | invalidIssue 4 | , validIssue 5 | , updatedValidIssue 6 | 7 | -- * Repo 8 | , validRepo 9 | , updatedValidRepo 10 | ) where 11 | 12 | import IW.Core.Issue (Issue (..), Label (..)) 13 | import IW.Core.Repo (Repo (..), RepoName (..), RepoOwner (..), Category (..)) 14 | import IW.Core.SqlArray (SqlArray (..)) 15 | import IW.Sync.Search (mkRepoCabalUrl) 16 | 17 | 18 | validRepo :: Repo 19 | validRepo = Repo 20 | { repoOwner = RepoOwner "owner123" 21 | , repoName = RepoName "repo123" 22 | , repoDescr = "A test repo." 23 | , repoCategories = SqlArray [Category "FFI"] 24 | , repoCabalUrl = mkRepoCabalUrl (RepoOwner "owner123") (RepoName "repo123") Nothing 25 | } 26 | 27 | updatedValidRepo :: Repo 28 | updatedValidRepo = Repo 29 | { repoOwner = RepoOwner "owner123" 30 | , repoName = RepoName "repo123" 31 | , repoDescr = "Updating test repo description." 32 | , repoCategories = SqlArray 33 | [ Category "Testing" 34 | , Category "FFI" 35 | ] 36 | , repoCabalUrl = mkRepoCabalUrl (RepoOwner "owner123") (RepoName "repo123") Nothing 37 | } 38 | 39 | invalidIssue :: Issue 40 | invalidIssue = Issue 41 | { issueRepoOwner = RepoOwner "robert" 42 | , issueRepoName = RepoName "instajam" 43 | , issueNumber = 1 44 | , issueTitle = "Not an issue" 45 | , issueBody = "" 46 | , issueLabels = SqlArray [Label "help wanted"] 47 | } 48 | 49 | validIssue :: Issue 50 | validIssue = Issue 51 | { issueRepoOwner = RepoOwner "owner123" 52 | , issueRepoName = RepoName "repo123" 53 | , issueNumber = 123 54 | , issueTitle = "Another test issue" 55 | , issueBody = "Just another test issue" 56 | , issueLabels = SqlArray [Label "help wanted"] 57 | } 58 | 59 | updatedValidIssue :: Issue 60 | updatedValidIssue = Issue 61 | { issueRepoOwner = RepoOwner "owner123" 62 | , issueRepoName = RepoName "repo123" 63 | , issueNumber = 123 64 | , issueTitle = "Update test issue" 65 | , issueBody = "Updated test issue body" 66 | , issueLabels = SqlArray [Label "low hanging fruit", Label "good first issue"] 67 | } 68 | -------------------------------------------------------------------------------- /test/Test/Assert.hs: -------------------------------------------------------------------------------- 1 | {- | We use @hspec@ testing framework and it doesn't support monad transformers. 2 | At this moment there's no testing framework that supports monad transformers. So 3 | we need to pass @AppEnv@ manually to every function. 4 | All functions take `AppEnv` as last argument. Like this one: 5 | @ 6 | satisfies :: App a -> (a -> Bool) -> AppEnv -> Expectation 7 | @ 8 | Because of that, there're multiple ways to write tests: 9 | @ 10 | 1. satisfies action isJust env 11 | 2. (action `satisfies` isJust) env 12 | 3. action `satisfies` isJust $ env 13 | 4. env & action `satisfies` isJust 14 | @ 15 | We can go even further and introduce fancy operators, so this code can be 16 | written in more concise way. But this is TBD. 17 | @ 18 | env & action @? isJust 19 | @ 20 | -} 21 | 22 | module Test.Assert 23 | ( failsWith 24 | , satisfies 25 | , succeeds 26 | , equals 27 | , returnsSame 28 | ) where 29 | 30 | import Test.Hspec (Expectation, expectationFailure, shouldBe, shouldSatisfy) 31 | 32 | import IW.App (App, AppEnv, AppError (..), AppErrorType, runAppAsIO) 33 | 34 | 35 | -- | Checks that given action runs successfully. 36 | succeeds :: (Show a) => App a -> AppEnv -> Expectation 37 | succeeds = (`satisfies` const True) 38 | 39 | -- | Checks whether return result of the action satisfies given predicate. 40 | satisfies :: (Show a) => App a -> (a -> Bool) -> AppEnv -> Expectation 41 | satisfies app p env = runAppAsIO env app >>= \case 42 | Left e -> expectationFailure $ "Expected 'Success' but got: " <> show e 43 | Right a -> a `shouldSatisfy` p 44 | 45 | -- | Checks whether action fails and returns given error. 46 | failsWith :: (Show a) => App a -> AppErrorType -> AppEnv -> Expectation 47 | failsWith app err env = runAppAsIO env app >>= \case 48 | Left AppError{..} -> appErrorType `shouldBe` err 49 | Right a -> expectationFailure $ 50 | "Expected 'Failure' with: " <> show err <> " but got: " <> show a 51 | 52 | -- | Checks whether action returns expected value. 53 | equals :: (Show a, Eq a) => App a -> a -> AppEnv -> Expectation 54 | equals app v env = runAppAsIO env app >>= \case 55 | Right a -> a `shouldBe` v 56 | Left e -> expectationFailure $ "Expected 'Success' but got: " <> show e 57 | 58 | -- | Checks whether two actions return the same result. 59 | returnsSame :: (Show a, Eq a) => App a -> App a -> AppEnv -> Expectation 60 | returnsSame app1 app2 env = do 61 | result1 <- runAppAsIO env app1 62 | result2 <- runAppAsIO env app2 63 | result1 `shouldBe` result2 64 | -------------------------------------------------------------------------------- /src/IW/Effects/Cabal.hs: -------------------------------------------------------------------------------- 1 | {- | This module contains the class definitiion of 'MonadCabal' and 2 | an instance of 'MonadCabal' for the 'App' monad. Instances of 3 | 'MonadCabal' have a 'getCabalCategories' action that returns @['Category']@ 4 | given a 'RepoOwner' and 'RepoName'. It does so by downloading a @.cabal@ file 5 | and parsing the @category@ field of the file. 6 | -} 7 | 8 | module IW.Effects.Cabal 9 | ( MonadCabal (..) 10 | 11 | -- * Internals 12 | , getCabalCategoriesImpl 13 | , repoCabalUrl 14 | ) where 15 | 16 | import Data.Text (splitOn, strip) 17 | import Distribution.PackageDescription 18 | import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, 19 | runParseResult) 20 | 21 | import IW.App (App (..), AppErrorType (..), CabalPError (..), CabalErrorInfo (..), 22 | WithError, throwError) 23 | import IW.Core.Repo (Repo (..), Category (..)) 24 | import IW.Effects.Download (MonadDownload (..)) 25 | 26 | 27 | -- | Describes a monad that returns @['Category']@ given a 'Repo'. 28 | class Monad m => MonadCabal m where 29 | getCabalCategories :: Repo -> m [Category] 30 | 31 | instance MonadCabal App where 32 | getCabalCategories = getCabalCategoriesImpl 33 | 34 | type WithCabal env m = (MonadDownload m, WithLog env m, WithError m) 35 | 36 | {- | This function takes a 'Repo' and either returns @['Category']@, or 37 | throws a 'CabalParseError' error. This function may also throw any one of the 38 | errors inherited by the use of 'downloadFile' defined in "IW.Effects.Download". 39 | -} 40 | getCabalCategoriesImpl 41 | :: forall env m. 42 | WithCabal env m 43 | => Repo 44 | -> m [Category] 45 | getCabalCategoriesImpl Repo{..} = do 46 | cabalFile <- downloadFile repoCabalUrl 47 | let (warnings, result) = runParseResult $ parseGenericPackageDescription cabalFile 48 | log D $ "Parsed cabal file downloaded from " <> show repoCabalUrl 49 | <> " with these warnings: " <> show warnings 50 | -- | The @result@ has the type @'Either' ('Maybe' 'Distribution.Types.Version.Version', ['Distribution.Parsec.Common.PError']) a@. 51 | case result of 52 | Left err -> do 53 | let cabalParseErr = CabalParseError $ CabalErrorInfo { cabalVersion = fst err 54 | , cabalPErrors = CabalPError <$> snd err 55 | } 56 | log E $ "Failed to parse cabal file downloaded from " <> show repoCabalUrl 57 | <> " with these errors: " <> show cabalParseErr 58 | throwError cabalParseErr 59 | Right genPkgDescr -> do 60 | log I $ "Successfuly parsed cabal file downloaded from " <> show repoCabalUrl 61 | pure $ categoryNames genPkgDescr 62 | 63 | -- | Parses a 'GenericPackageDescription' for @['Category']@. 64 | categoryNames :: GenericPackageDescription -> [Category] 65 | categoryNames genPkgDescr = Category <$> splitCategories genPkgDescr 66 | where 67 | splitCategories :: GenericPackageDescription -> [Text] 68 | splitCategories = splitAndStrip "," . toText . category . packageDescription 69 | 70 | {- | This function takes a delimeter and a delimeter seperated value, 71 | and returns a list of 'Text' values stripped of excess whitespace. 72 | Note that it returns an empty list when an empty delimeter seperated value is 73 | passed in. This prevents the value @[""]@ from being returned. 74 | -} 75 | splitAndStrip :: Text -> Text -> [Text] 76 | splitAndStrip _ "" = [] 77 | splitAndStrip delim text = strip <$> splitOn delim text 78 | -------------------------------------------------------------------------------- /frontend/src/Main.elm: -------------------------------------------------------------------------------- 1 | module Main exposing (..) 2 | 3 | import Browser 4 | import Cmd.Extra exposing (perform) 5 | import Html exposing (Html, text, div, h1, h2, button, input, text) 6 | import Html.Attributes exposing (src, class, disabled, placeholder, type_, value) 7 | import Html.Events exposing (onClick, onInput) 8 | 9 | import IW.Api exposing (ResultErr, getIssues) 10 | import IW.Core.Types exposing (Issue) 11 | import IW.Cmd exposing (noCmd) 12 | 13 | 14 | ---- MODEL ---- 15 | 16 | type alias Model = 17 | { issues : List Issue 18 | , page : Int 19 | , err : Bool 20 | , labels : List String 21 | , inputLabel : String 22 | , categories : List String 23 | , inputCategory : String 24 | } 25 | 26 | init : ( Model, Cmd Msg ) 27 | init = noCmd 28 | { issues = [] 29 | , page = 0 30 | , err = False 31 | , labels = [] 32 | , inputLabel = "" 33 | , categories = [] 34 | , inputCategory = "" 35 | } 36 | 37 | ---- UPDATE ---- 38 | 39 | type Msg 40 | = NoOp 41 | | AddLabel String 42 | | DeleteLabel String 43 | | UpdateLabel String 44 | | AddCategory String 45 | | DeleteCategory String 46 | | UpdateCategory String 47 | | GetIssues 48 | | GetIssuesRes (ResultErr (List Issue)) 49 | | Refresh 50 | 51 | update : Msg -> Model -> ( Model, Cmd Msg ) 52 | update msg model = case msg of 53 | NoOp -> noCmd model 54 | AddLabel l -> 55 | ( {model| labels = add l model.labels, inputLabel = ""} 56 | , perform <| UpdateLabel "" 57 | ) 58 | DeleteLabel l -> noCmd {model| labels = delete l model.labels} 59 | UpdateLabel l -> noCmd {model| inputLabel = l} 60 | AddCategory c -> 61 | ( {model| categories = add c model.categories, inputCategory = ""} 62 | , perform <| UpdateCategory "" 63 | ) 64 | DeleteCategory c -> noCmd {model| categories = delete c model.categories} 65 | UpdateCategory c -> noCmd {model| inputCategory = c} 66 | GetIssues -> (model, getIssues model.labels model.page GetIssuesRes) 67 | GetIssuesRes res -> case res of 68 | Ok resIssues -> noCmd {model| issues = resIssues} 69 | Err err -> noCmd {model| err = True} 70 | Refresh -> init 71 | 72 | delete : String -> List String -> List String 73 | delete str l = case l of 74 | [] -> [] 75 | (cur::rest) -> if str == cur then rest else cur :: delete str rest 76 | 77 | add : String -> List String -> List String 78 | add str l = 79 | if str /= "" && not (List.member str l) 80 | then str :: l 81 | else l 82 | 83 | ---- VIEW ---- 84 | 85 | view : Model -> Html Msg 86 | view m = div [] 87 | [ h1 [] [text "Issue Wanted testing page"] 88 | 89 | , div [] 90 | [ h2 [] [text "Labels"] 91 | , div [] <| List.map (\l -> div [class "tag"] [text l, button [onClick <| DeleteLabel l] [text "x"]]) m.labels 92 | , input [ type_ "text", placeholder "Label...", value m.inputLabel, onInput UpdateLabel] [] 93 | , button [onClick <| AddLabel m.inputLabel] [text "Add"] 94 | ] 95 | 96 | , div [] 97 | [ h2 [] [text "Categories"] 98 | , div [] <| List.map (\c -> div [class "tag"] [text c, button [onClick <| DeleteCategory c] [text "x"]]) m.categories 99 | , input [ type_ "text", placeholder "Category...", value m.inputCategory, onInput UpdateCategory] [] 100 | , button [onClick <| AddCategory m.inputCategory] [text "Add"] 101 | ] 102 | 103 | , div [] [ button [onClick GetIssues] [text "Get Issues"] ] 104 | , div [class "err"] (if m.err then [text "Get errored"] else []) 105 | , div [] [text <| if m.issues == [] then "No Issues" else "Some issues"] 106 | , div [] 107 | [ button [] [text "<"] 108 | , text <| String.fromInt m.page 109 | , button [] [text ">"] 110 | ] 111 | , button [onClick Refresh] [text "Refresh"] 112 | ] 113 | 114 | ---- PROGRAM ---- 115 | 116 | main : Program () Model Msg 117 | main = Browser.element 118 | { view = view 119 | , init = \_ -> init 120 | , update = update 121 | , subscriptions = always Sub.none 122 | } 123 | 124 | -- Util 125 | isNothing : Maybe a -> Bool 126 | isNothing x = case x of 127 | Nothing -> True 128 | _ -> False 129 | -------------------------------------------------------------------------------- /frontend/src/registerServiceWorker.js: -------------------------------------------------------------------------------- 1 | // In production, we register a service worker to serve assets from local cache. 2 | 3 | // This lets the app load faster on subsequent visits in production, and gives 4 | // it offline capabilities. However, it also means that developers (and users) 5 | // will only see deployed updates on the "N+1" visit to a page, since previously 6 | // cached resources are updated in the background. 7 | 8 | // To learn more about the benefits of this model, read https://goo.gl/KwvDNy. 9 | // This link also includes instructions on opting out of this behavior. 10 | 11 | const isLocalhost = Boolean( 12 | window.location.hostname === 'localhost' || 13 | // [::1] is the IPv6 localhost address. 14 | window.location.hostname === '[::1]' || 15 | // 127.0.0.1/8 is considered localhost for IPv4. 16 | window.location.hostname.match( 17 | /^127(?:\.(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)){3}$/ 18 | ) 19 | ); 20 | 21 | export default function register() { 22 | if (process.env.NODE_ENV === 'production' && 'serviceWorker' in navigator) { 23 | // The URL constructor is available in all browsers that support SW. 24 | const publicUrl = new URL(process.env.PUBLIC_URL, window.location); 25 | if (publicUrl.origin !== window.location.origin) { 26 | // Our service worker won't work if PUBLIC_URL is on a different origin 27 | // from what our page is served on. This might happen if a CDN is used to 28 | // serve assets; see https://github.com/facebookincubator/create-react-app/issues/2374 29 | return; 30 | } 31 | 32 | window.addEventListener('load', () => { 33 | const swUrl = `${process.env.PUBLIC_URL}/service-worker.js`; 34 | 35 | if (!isLocalhost) { 36 | // Is not local host. Just register service worker 37 | registerValidSW(swUrl); 38 | } else { 39 | // This is running on localhost. Lets check if a service worker still exists or not. 40 | checkValidServiceWorker(swUrl); 41 | } 42 | }); 43 | } 44 | } 45 | 46 | function registerValidSW(swUrl) { 47 | navigator.serviceWorker 48 | .register(swUrl) 49 | .then(registration => { 50 | registration.onupdatefound = () => { 51 | const installingWorker = registration.installing; 52 | installingWorker.onstatechange = () => { 53 | if (installingWorker.state === 'installed') { 54 | if (navigator.serviceWorker.controller) { 55 | // At this point, the old content will have been purged and 56 | // the fresh content will have been added to the cache. 57 | // It's the perfect time to display a "New content is 58 | // available; please refresh." message in your web app. 59 | console.log('New content is available; please refresh.'); 60 | } else { 61 | // At this point, everything has been precached. 62 | // It's the perfect time to display a 63 | // "Content is cached for offline use." message. 64 | console.log('Content is cached for offline use.'); 65 | } 66 | } 67 | }; 68 | }; 69 | }) 70 | .catch(error => { 71 | console.error('Error during service worker registration:', error); 72 | }); 73 | } 74 | 75 | function checkValidServiceWorker(swUrl) { 76 | // Check if the service worker can be found. If it can't reload the page. 77 | fetch(swUrl) 78 | .then(response => { 79 | // Ensure service worker exists, and that we really are getting a JS file. 80 | if ( 81 | response.status === 404 || 82 | response.headers.get('content-type').indexOf('javascript') === -1 83 | ) { 84 | // No service worker found. Probably a different app. Reload the page. 85 | navigator.serviceWorker.ready.then(registration => { 86 | registration.unregister().then(() => { 87 | window.location.reload(); 88 | }); 89 | }); 90 | } else { 91 | // Service worker found. Proceed as normal. 92 | registerValidSW(swUrl); 93 | } 94 | }) 95 | .catch(() => { 96 | console.log( 97 | 'No internet connection found. App is running in offline mode.' 98 | ); 99 | }); 100 | } 101 | 102 | export function unregister() { 103 | if ('serviceWorker' in navigator) { 104 | navigator.serviceWorker.ready.then(registration => { 105 | registration.unregister(); 106 | }); 107 | } 108 | } 109 | -------------------------------------------------------------------------------- /src/IW/Db/Functions.hs: -------------------------------------------------------------------------------- 1 | -- | MonadReader wrappers around postgresql-simple library. 2 | 3 | module IW.Db.Functions 4 | ( WithDb 5 | , initialisePool 6 | 7 | -- * Sql functions 8 | , query 9 | , queryNamed 10 | , queryRaw 11 | , execute 12 | , executeNamed 13 | , executeRaw 14 | , executeMany 15 | , returning 16 | 17 | -- * Error handling 18 | , asSingleRow 19 | , singleRowError 20 | ) where 21 | 22 | import PgNamed (NamedParam, PgNamedError) 23 | 24 | import IW.App.Env (DbPool, Has, grab) 25 | import IW.App.Error (AppErrorType (..), WithError, throwError, throwOnNothingM) 26 | 27 | import qualified Data.Pool as Pool 28 | import qualified Database.PostgreSQL.Simple as Sql 29 | import qualified PgNamed as Sql 30 | 31 | 32 | -- | Constraint for monadic actions that wants access to database. 33 | type WithDb env m = (MonadReader env m, Has DbPool env, MonadIO m) 34 | 35 | -- | Create 'Pool.Pool' by given credentials. 36 | initialisePool :: ByteString -> IO DbPool 37 | initialisePool credentials = Pool.createPool (Sql.connectPostgreSQL credentials) Sql.close 10 5 10 38 | 39 | -- | Performs a query without arguments and returns the resulting rows. 40 | queryRaw 41 | :: forall res env m . 42 | (WithDb env m, FromRow res) 43 | => Sql.Query 44 | -> m [res] 45 | queryRaw q = withPool $ \conn -> Sql.query_ conn q 46 | {-# INLINE queryRaw #-} 47 | 48 | -- | Performs a query with arguments and returns the resulting rows with the 49 | -- given parameters. 50 | query 51 | :: forall res args env m . 52 | (WithDb env m, ToRow args, FromRow res) 53 | => Sql.Query 54 | -> args 55 | -> m [res] 56 | query q args = withPool $ \conn -> Sql.query conn q args 57 | {-# INLINE query #-} 58 | 59 | -- | Performs a query with named parameters and returns a list of rows. 60 | queryNamed 61 | :: (WithError m, WithDb env m, FromRow res) 62 | => Sql.Query 63 | -> [NamedParam] 64 | -> m [res] 65 | queryNamed q params = withPool (\conn -> runExceptT $ Sql.queryNamed conn q params) 66 | >>= liftDbError 67 | {-# INLINE queryNamed #-} 68 | 69 | -- | Executes a query without arguments that is not expected to return results. 70 | executeRaw 71 | :: WithDb env m 72 | => Sql.Query 73 | -> m () 74 | executeRaw q = withPool $ \conn -> void $ Sql.execute_ conn q 75 | {-# INLINE executeRaw #-} 76 | 77 | -- | Executes a query with parameters that is not expected to return results. 78 | execute 79 | :: forall args env m . 80 | (WithDb env m, ToRow args) 81 | => Sql.Query 82 | -> args 83 | -> m () 84 | execute q args = withPool $ \conn -> void $ Sql.execute conn q args 85 | {-# INLINE execute #-} 86 | 87 | -- | Executes a multi-row query that is not expected to return results. 88 | executeMany 89 | :: (WithDb env m, ToRow args) 90 | => Sql.Query 91 | -> [args] 92 | -> m () 93 | executeMany q args = withPool $ \conn -> void $ Sql.executeMany conn q args 94 | {-# INLINE executeMany #-} 95 | 96 | -- | Executes a query with named parameters, returning the number of rows affected. 97 | executeNamed 98 | :: (WithError m, WithDb env m) 99 | => Sql.Query 100 | -> [NamedParam] 101 | -> m Int64 102 | executeNamed q params = withPool (\conn -> runExceptT $ Sql.executeNamed conn q params) 103 | >>= liftDbError 104 | {-# INLINE executeNamed #-} 105 | 106 | -- | Executes a multi-row query that is expected to return results. 107 | -- A @RETURNING@ statement needs to be in the SQL query. 108 | returning 109 | :: (WithDb env m, ToRow args, FromRow res) 110 | => Sql.Query 111 | -> [args] 112 | -> m [res] 113 | returning q args = withPool $ \conn -> Sql.returning conn q args 114 | {-# INLINE returning #-} 115 | 116 | -- | Perform action that needs database connection. 117 | withPool :: WithDb env m => (Sql.Connection -> IO b) -> m b 118 | withPool f = do 119 | pool <- grab @DbPool 120 | liftIO $ Pool.withResource pool f 121 | {-# INLINE withPool #-} 122 | 123 | ---------------------------------------------------------------------------- 124 | -- Error helpers 125 | ---------------------------------------------------------------------------- 126 | 127 | -- | Helper function working with results from a database when you expect 128 | -- only one row to be returned. 129 | asSingleRow :: WithError m => m [a] -> m a 130 | asSingleRow res = withFrozenCallStack $ throwOnNothingM 131 | singleRowError 132 | (viaNonEmpty head <$> res) 133 | 134 | -- | Lift database named parameters errors. 135 | liftDbError :: WithError m => Either PgNamedError a -> m a 136 | liftDbError = either (throwError . DbNamedError) pure 137 | {-# INLINE liftDbError #-} 138 | 139 | singleRowError :: AppErrorType 140 | singleRowError = DbError "Expected a single row, but got none" 141 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Issue Wanted 2 | 3 | [![CircleCI](https://circleci.com/gh/kowainik/issue-wanted.svg?style=svg)](https://circleci.com/gh/kowainik/issue-wanted) 4 | [![Hackage](https://img.shields.io/hackage/v/issue-wanted.svg?logo=haskell)](https://hackage.haskell.org/package/issue-wanted) 5 | [![MPL-2.0 license](https://img.shields.io/badge/license-MPL--2.0-blue.svg)](https://github.com/kowainik/issue-wanted/blob/master/LICENSE) 6 | 7 | `issue-wanted` is a web application focused on improving the open-source Haskell 8 | community by centralizing GitHub issues across many Haskell repositories into a 9 | single location. The goals of `issue-wanted` are to make it easier for 10 | programmers of all skill levels to find Haskell projects to contribute to, 11 | increase the number of contributions to open-source Haskell projects, and 12 | encourage more programmers to become a part of the Haskell community. 13 | 14 | ## Architecture Description 15 | 16 | Main work on this project was done during Google Summer of Code 2019. For anyone 17 | interested in the details of how `issue-wanted` was implemented and why certain 18 | design choices were made, check out these blog posts: 19 | 20 | * [GSoC 2019 - Building A Web Application with Haskell](https://rashadg1030.github.io/rashad-blog/6.html) 21 | * [Guide to Implementing Custom Monadic Effects in Issue-Wanted](https://rashadg1030.github.io/rashad-blog/7.html) 22 | * [GSoC 2019 - Final Evaluation](https://rashadg1030.github.io/rashad-blog/8.html) 23 | 24 | ## Backend 25 | 26 | ### Prerequisites (what you need to have locally) 27 | 28 | You will need to have the following installed on your system in order to build and test `issue-wanted`. Click on the links to learn how to install each one: 29 | 30 | 1. [ghc](https://www.haskell.org/ghcup/) 31 | 2. [cabal](https://www.haskell.org/cabal/) or [stack](https://docs.haskellstack.org/en/stable/README/) 32 | 3. [docker](https://docs.docker.com/v17.12/install/) 33 | 4. `libpq-dev`: run the command `sudo apt install libpq-dev` to install. 34 | 35 | With `docker` installed, open up a terminal (make sure your in the 36 | `issue-wanted` directory) and run the command `make postgres`. This will setup 37 | the database for you and you should be ready to go! 38 | 39 | Follow the instructions under 40 | [`How to run server`](https://github.com/kowainik/issue-wanted/tree/rashadg1030/81-Document-Postgres-setup#how-to-run-server) 41 | and test the endpoints to see if everything is set up correctly. 42 | 43 | Refer to issue [#81](https://github.com/kowainik/issue-wanted/issues/81) if 44 | you're still having trouble. 45 | 46 | ### How to build 47 | 48 | To build the project, open up a terminal in the base folder and run 49 | 50 | ```shell 51 | stack build 52 | ``` 53 | 54 | or 55 | 56 | ```shell 57 | cabal v2-build 58 | ``` 59 | 60 | ### How to generate Elm types 61 | 62 | If any types are changed one should update the generated to Elm types by running: 63 | 64 | ```shell 65 | stack run generate-elm 66 | ``` 67 | 68 | or 69 | 70 | ```shell 71 | cabal v2-run generate-elm 72 | ``` 73 | 74 | ### How to run server 75 | 76 | For testing the `issue-wanted` server follow these steps: 77 | 78 | 1. Open up the terminal in the base folder and run `stack build` 79 | 2. Run the command `stack exec issue-wanted` 80 | 81 | The server will begin running at `http://localhost:8080/`. 82 | 83 | ### API 84 | 85 | Issue-wanted endpoints available: 86 | 87 | | Endpoint | Description | 88 | |------------------------------|-------------| 89 | | `/issues` | Returns all issues. | 90 | | `/issues/:id` | Returns a single issue with the corresponding id. | 91 | | `/issues?label=