├── .github └── workflows │ └── ci.yaml ├── .gitignore ├── LICENSE.markdown ├── README.markdown ├── cabal.project ├── config ├── brittany.yaml ├── cloud-formation.yaml ├── hlint.yaml └── stylish-haskell.yaml ├── data ├── favicon.ico ├── logo.png └── tachyons-4-12-0.css ├── docker └── Dockerfile ├── monadoc.cabal ├── src ├── exe │ └── Main.hs ├── lib │ ├── Monadoc.hs │ └── Monadoc │ │ ├── Data │ │ ├── Commit.hs │ │ ├── Migrations.hs │ │ ├── Options.hs │ │ └── Version.hs │ │ ├── Handler │ │ ├── Account.hs │ │ ├── Favicon.hs │ │ ├── GitHubCallback.hs │ │ ├── Index.hs │ │ ├── LogOut.hs │ │ ├── Logo.hs │ │ ├── Ping.hs │ │ ├── Robots.hs │ │ ├── Search.hs │ │ ├── Tachyons.hs │ │ └── Throw.hs │ │ ├── Main.hs │ │ ├── Prelude.hs │ │ ├── Server │ │ ├── Application.hs │ │ ├── Common.hs │ │ ├── Main.hs │ │ ├── Middleware.hs │ │ ├── Router.hs │ │ ├── Settings.hs │ │ └── Template.hs │ │ ├── Type │ │ ├── App.hs │ │ ├── Binary.hs │ │ ├── Cabal │ │ │ ├── ModuleName.hs │ │ │ ├── PackageName.hs │ │ │ ├── Version.hs │ │ │ └── VersionRange.hs │ │ ├── Config.hs │ │ ├── ConfigResult.hs │ │ ├── Context.hs │ │ ├── Etag.hs │ │ ├── GitHub │ │ │ ├── Login.hs │ │ │ ├── User.hs │ │ │ └── UserId.hs │ │ ├── Guid.hs │ │ ├── Migration.hs │ │ ├── MigrationMismatch.hs │ │ ├── NotFoundException.hs │ │ ├── Path.hs │ │ ├── Revision.hs │ │ ├── Route.hs │ │ ├── Service.hs │ │ ├── Sha256.hs │ │ ├── Size.hs │ │ ├── TestException.hs │ │ ├── Timestamp.hs │ │ ├── Url.hs │ │ ├── User.hs │ │ └── WithCallStack.hs │ │ ├── Utility │ │ ├── Cabal.hs │ │ ├── Console.hs │ │ ├── Ghc.hs │ │ ├── Sql.hs │ │ ├── Time.hs │ │ └── Utf8.hs │ │ └── Worker │ │ └── Main.hs ├── script │ ├── brittany.hs │ ├── ghcid.hs │ ├── hlint.hs │ ├── purple-yolk.hs │ ├── set-commit-hash.hs │ └── stylish-haskell.hs └── test │ ├── Main.hs │ ├── Monadoc │ ├── Data │ │ ├── CommitSpec.hs │ │ ├── MigrationsSpec.hs │ │ ├── OptionsSpec.hs │ │ └── VersionSpec.hs │ ├── Handler │ │ ├── AccountSpec.hs │ │ ├── FaviconSpec.hs │ │ ├── GitHubCallbackSpec.hs │ │ ├── IndexSpec.hs │ │ ├── LogOutSpec.hs │ │ ├── LogoSpec.hs │ │ ├── PingSpec.hs │ │ ├── RobotsSpec.hs │ │ ├── SearchSpec.hs │ │ ├── TachyonsSpec.hs │ │ └── ThrowSpec.hs │ ├── MainSpec.hs │ ├── Server │ │ ├── ApplicationSpec.hs │ │ ├── CommonSpec.hs │ │ ├── MainSpec.hs │ │ ├── MiddlewareSpec.hs │ │ ├── RouterSpec.hs │ │ ├── SettingsSpec.hs │ │ └── TemplateSpec.hs │ ├── Type │ │ ├── AppSpec.hs │ │ ├── BinarySpec.hs │ │ ├── Cabal │ │ │ ├── ModuleNameSpec.hs │ │ │ ├── PackageNameSpec.hs │ │ │ ├── VersionRangeSpec.hs │ │ │ └── VersionSpec.hs │ │ ├── ConfigResultSpec.hs │ │ ├── ConfigSpec.hs │ │ ├── ContextSpec.hs │ │ ├── EtagSpec.hs │ │ ├── GitHub │ │ │ ├── LoginSpec.hs │ │ │ ├── UserIdSpec.hs │ │ │ └── UserSpec.hs │ │ ├── GuidSpec.hs │ │ ├── MigrationMismatchSpec.hs │ │ ├── MigrationSpec.hs │ │ ├── NotFoundExceptionSpec.hs │ │ ├── PathSpec.hs │ │ ├── RevisionSpec.hs │ │ ├── RouteSpec.hs │ │ ├── ServiceSpec.hs │ │ ├── Sha256Spec.hs │ │ ├── SizeSpec.hs │ │ ├── TestExceptionSpec.hs │ │ ├── TimestampSpec.hs │ │ ├── UrlSpec.hs │ │ ├── UserSpec.hs │ │ └── WithCallStackSpec.hs │ ├── Utility │ │ ├── CabalSpec.hs │ │ ├── ConsoleSpec.hs │ │ ├── GhcSpec.hs │ │ ├── SqlSpec.hs │ │ ├── TimeSpec.hs │ │ └── Utf8Spec.hs │ └── Worker │ │ └── MainSpec.hs │ └── MonadocSpec.hs └── stack.yaml /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | pull_request: 5 | branches: 6 | - main 7 | push: 8 | branches: 9 | - main 10 | 11 | jobs: 12 | 13 | build: 14 | name: build (${{ matrix.os }}) 15 | strategy: 16 | matrix: 17 | os: [ ubuntu-18.04, macos-10.15, windows-2019 ] 18 | ghc: [ '8.10' ] 19 | cabal: [ '3.2' ] 20 | runs-on: ${{ matrix.os }} 21 | steps: 22 | 23 | - uses: actions/checkout@v2 24 | 25 | - id: setup-haskell 26 | uses: actions/setup-haskell@v1.1 27 | with: 28 | ghc-version: ${{ matrix.ghc }} 29 | cabal-version: ${{ matrix.cabal }} 30 | 31 | - run: cabal freeze 32 | 33 | - uses: actions/cache@v2 34 | with: 35 | path: ${{ steps.setup-haskell.outputs.cabal-store }} 36 | key: ${{ matrix.os }}-${{ matrix.ghc }}-${{ matrix.cabal }}-${{ hashFiles('cabal.project.freeze') }} 37 | restore-keys: | 38 | ${{ matrix.os }}-${{ matrix.ghc }}-${{ matrix.cabal }}- 39 | ${{ matrix.os }}-${{ matrix.ghc }}- 40 | 41 | - run: runghc src/script/set-commit-hash.hs src/lib/Monadoc/Data/Commit.hs ${{ github.sha }} 42 | 43 | - run: cabal build --only-dependencies 44 | 45 | - run: cabal build 46 | 47 | - run: cabal test --test-show-details direct 48 | 49 | - run: cabal install --install-method copy --installdir docker 50 | 51 | - uses: actions/upload-artifact@v2 52 | with: 53 | path: docker/monadoc* 54 | name: monadoc-${{ matrix.os }}-${{ github.sha }} 55 | 56 | - if: matrix.os == 'ubuntu-18.04' 57 | run: cp --recursive data /opt/ghc/8.10.1/lib/ghc-8.10.1 docker 58 | 59 | - if: matrix.os == 'ubuntu-18.04' 60 | uses: docker/build-push-action@v1 61 | with: 62 | username: taylorfausak 63 | password: ${{ secrets.DOCKER_PASSWORD }} 64 | repository: taylorfausak/monadoc 65 | tags: ${{ github.sha }} 66 | path: docker 67 | 68 | deploy: 69 | if: github.ref == 'refs/heads/main' 70 | needs: build 71 | runs-on: ubuntu-18.04 72 | steps: 73 | 74 | - run: > 75 | curl 76 | --header 'Content-Type: application/json' 77 | --data '{ "content": "Deploying commit `${{ github.sha }}` ..." }' 78 | '${{ secrets.DISCORD_URL }}' 79 | 80 | - uses: actions/checkout@v2 81 | 82 | - uses: aws-actions/configure-aws-credentials@v1 83 | with: 84 | aws-access-key-id: ${{ secrets.AWS_ACCESS_KEY_ID }} 85 | aws-secret-access-key: ${{ secrets.AWS_SECRET_ACCESS_KEY }} 86 | aws-region: us-east-1 87 | 88 | - uses: aws-actions/aws-cloudformation-github-deploy@v1 89 | with: 90 | name: monadoc 91 | template: config/cloud-formation.yaml 92 | parameter-overrides: ClientSecret=${{ secrets.CLIENT_SECRET }},DiscordUrl=${{ secrets.DISCORD_URL }},TagName=${{ github.sha }} 93 | no-fail-on-empty-changeset: '1' 94 | capabilities: CAPABILITY_NAMED_IAM 95 | 96 | - if: success() 97 | run: > 98 | curl 99 | --header 'Content-Type: application/json' 100 | --data '{ "content": "Successfully deployed `${{ github.sha }}`." }' 101 | '${{ secrets.DISCORD_URL }}' 102 | 103 | - if: failure() 104 | run: > 105 | curl 106 | --header 'Content-Type: application/json' 107 | --data '{ "content": "Failed to deploy `${{ github.sha }}`!" }' 108 | '${{ secrets.DISCORD_URL }}' 109 | 110 | - if: cancelled() 111 | run: > 112 | curl 113 | --header 'Content-Type: application/json' 114 | --data '{ "content": "Cancelled deployment of `${{ github.sha }}`." }' 115 | '${{ secrets.DISCORD_URL }}' 116 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | /.stack-work/ 3 | /.vscode/ 4 | /*.sqlite3* 5 | /cabal.project.freeze 6 | /dist-newstyle/ 7 | /stack.yaml.lock 8 | -------------------------------------------------------------------------------- /LICENSE.markdown: -------------------------------------------------------------------------------- 1 | Copyright 2020 Taylor Fausak 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 8 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND 9 | FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 10 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM 11 | LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR 12 | OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 13 | PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | [![](https://github.com/tfausak/monadoc/workflows/CI/badge.svg)](https://github.com/tfausak/monadoc/actions) 2 | 3 | # [Monadoc](https://www.monadoc.com) :bookmark: 4 | 5 | Better Haskell documentation. This is still a work in progress. I've made a bunch of proofs of concept before. This one is meant to be a real service. Here's a summary of the previous attempts: 6 | 7 | - https://github.com/tfausak/grawlix/tree/3189fa2: This introduced the basic idea of commenting on Haskell documentation. It started life as a bookmarklet. I briefly considered making browser extensions, but I figured that wouldn't be able to get enough traction. So I started on the path of parsing the package index and building my own subset of the documentation. I made it a fair ways in that direction, but stopped for some reason. 8 | 9 | - https://github.com/tfausak/monadoc-1/tree/37e997f: This one tries to avoid the mess of the package index by proxying Hackage and overlaying commentary on it. Not a bad idea, but puts itself completely at the whims of Hackage. Also it requires dealing with the HTML output of Haddock, which is probably worse than dealing with the modules themselves. 10 | 11 | - https://github.com/tfausak/monadoc-2/tree/dac8787: This was exploring a different direction for infrastructure. Instead of running a typical server, this tried to set things up as an AWS Lambda behind an API Gateway. Although it was interesting and not as difficult as I expected, I decided against this because it's hard to deal with locally. 12 | 13 | - https://github.com/tfausak/monadoc-3/tree/90e36c1: I felt like the previous attempt spent too much time looking at infrastructure, so this tried to keep everything simple and live in a single file. The end result kind of crumbled under its own weight, but I did discover a lot of good things about the package index. 14 | 15 | - https://github.com/tfausak/monadoc-4/tree/86809fc: This attempt tried to focus on building a real service. By that I mean it deployed to AWS and was a site you could actually visit. It also implement login with GitHub, which allowed people to log in. Ultimately I ran into a roadblock with using GHC to parse Haskell files. 16 | 17 | I'm kind of surprised I've been at this in one way or another for so long. But at this point I feel like I have all the pieces of the puzzle: I know how to deal with the Hackage index, I know how to parse files with GHC, I can support logging in with GitHub, and I can deploy the whole thing to AWS. All that's left is to assemble that into a working product :) 18 | 19 | Here's a wishlist of features that I want to implement: 20 | 21 | - Basic pages for Hackage users, packages, versions, revisions, and modules, just like [Hackage](https://hackage.haskell.org/package/flow). 22 | - Pages for individual identifiers as well, like [ClojureDocs](https://clojuredocs.org/clojure.core/map). (As opposed or in addition to `#anchor` links on a module page.) 23 | - Type directed search like [Hoogle](https://hoogle.haskell.org/?hoogle=Ord%20a%20%3D%3E%20%5Ba%5D%20-%3E%20%5Ba%5D). 24 | - Inline source view like [APIdock](https://apidock.com/ruby/Enumerable/map). 25 | - Comments on anything (but especially identifiers) like [PHP](https://www.php.net/manual/en/function.str-pad). 26 | - Live search like on [CocoaPods](https://cocoapods.org). 27 | - Various maintainer tools like reverse dependencies (), licenses, and feeds/notifications about versions/comments. 28 | 29 | In addition, I want this project to be easy to hack on. That means it should build easily on Linux, macOS, and Windows with both Cabal and Stack. It shouldn't require any special infrastructure like Docker or Nix. It should prefer simpler code so that anyone can jump in. Whenever possible things should be tested and enforced by CI. 30 | 31 | ## TODO 32 | 33 | - [ ] Implement search in `src/lib/Monadoc/Handler/Search.hs`. 34 | - [ ] Allow template to vary by handler in `src/lib/Monadoc/Server/Template.hs`. 35 | - [ ] Remove handling for old files in `src/lib/Monadoc/Worker/Main.hs`. 36 | - [ ] Skip processing for things that haven't changed. 37 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | jobs: $ncpus 4 | 5 | package monadoc 6 | ghc-options: -j -Werror 7 | optimization: 2 8 | tests: true 9 | -------------------------------------------------------------------------------- /config/brittany.yaml: -------------------------------------------------------------------------------- 1 | conf_forward: 2 | options_ghc: 3 | - -XApplicativeDo 4 | - -XBangPatterns 5 | - -XBlockArguments 6 | - -XDataKinds 7 | - -XFlexibleContexts 8 | - -XNamedFieldPuns 9 | - -XNegativeLiterals 10 | - -XNoImplicitPrelude 11 | - -XNumDecimals 12 | - -XNumericUnderscores 13 | - -XOverloadedStrings 14 | - -XScopedTypeVariables 15 | - -XTypeApplications 16 | conf_layout: 17 | lconfig_cols: 79 18 | lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled } 19 | lconfig_indentPolicy: IndentPolicyLeft 20 | -------------------------------------------------------------------------------- /config/cloud-formation.yaml: -------------------------------------------------------------------------------- 1 | AWSTemplateFormatVersion: 2010-09-09 2 | Description: 3 | https://docs.aws.amazon.com/AWSCloudFormation/latest/UserGuide/Welcome.html 4 | 5 | # Be sure to update the domain's name servers to point to the hosted zone's 6 | # name servers, otherwise DNS resolution won't work. This step is manual 7 | # because the domain isn't managed by CloudFormation. 8 | 9 | # Certificates require manual validation. After creating a certificate with 10 | # CloudFormation, you must go to the certificate manager in the AWS console and 11 | # hit the "Create record in Route 53" button. 12 | 13 | # If you change the instance type, you will probably also want to change the 14 | # CPU and memory of the task definition. All of the instance's CPU is available 15 | # but some of the memory is taken. For example a t3a.micro instance has 2 vCPUs 16 | # and 1 GiB of memory, which turns into 2048 CPU units and 961 memory units. Be 17 | # sure to leave enough capacity for double instances on deploys! 18 | 19 | Parameters: 20 | 21 | AmiId: 22 | Type: String 23 | Default: ami-00c7c1cf5bdc913ed 24 | Description: 25 | The ECS optimized Amazon Machine Image (AMI) ID to use for EC2 instances 26 | in the auto scaling group. The default value was picked on 2020-06-26. 27 | # https://docs.aws.amazon.com/AmazonECS/latest/developerguide/retrieve-ecs-optimized_AMI.html 28 | 29 | ClientId: 30 | Type: String 31 | Default: 658122d4ef8c24039953 32 | Description: 33 | The client ID for the GitHub OAuth application. You can get this at 34 | . 35 | 36 | ClientSecret: 37 | Type: String 38 | Description: 39 | The client secret for the GitHub OAuth application. See the "ClientId" 40 | parameter for details. 41 | 42 | DiscordUrl: 43 | Type: String 44 | Description: 45 | The URL to the Discord webhook for reporting exceptions. This is the full 46 | URL, not just the ID and token. 47 | 48 | DomainName: 49 | Type: String 50 | Default: monadoc.com 51 | Description: 52 | The root (apex) domain name. You can include the final period after the 53 | TLD here, but you don't need to. 54 | 55 | PortNumber: 56 | Type: Number 57 | Default: 4444 58 | Description: 59 | The port number to bind inside the container. It's unlikely that you'll 60 | need to change this. 61 | 62 | TagName: 63 | Type: String 64 | Description: 65 | The Docker image tag to deploy. Usually this is the HEAD of the default 66 | branch, but it can be any tag that exists for the image in the registry. 67 | 68 | Resources: 69 | 70 | ApexCertificate: 71 | Type: AWS::CertificateManager::Certificate 72 | Properties: 73 | DomainName: !Ref DomainName 74 | ValidationMethod: DNS 75 | 76 | ApexDistribution: 77 | Type: AWS::CloudFront::Distribution 78 | Properties: 79 | DistributionConfig: 80 | Aliases: 81 | - !Ref DomainName 82 | DefaultCacheBehavior: 83 | ForwardedValues: 84 | QueryString: false 85 | TargetOriginId: !Ref DomainName 86 | ViewerProtocolPolicy: redirect-to-https 87 | Enabled: true 88 | HttpVersion: http2 89 | Origins: 90 | - CustomOriginConfig: 91 | OriginProtocolPolicy: http-only 92 | DomainName: !Select 93 | - 1 94 | - !Split 95 | - // 96 | - !GetAtt Bucket.WebsiteURL 97 | Id: !Ref DomainName 98 | ViewerCertificate: 99 | AcmCertificateArn: !Ref ApexCertificate 100 | MinimumProtocolVersion: TLSv1.2_2018 101 | SslSupportMethod: sni-only 102 | 103 | ApexRecordSet: 104 | Type: AWS::Route53::RecordSet 105 | Properties: 106 | AliasTarget: 107 | DNSName: !GetAtt ApexDistribution.DomainName 108 | HostedZoneId: Z2FDTNDATAQYW2 109 | HostedZoneId: !Ref HostedZone 110 | Name: !Ref DomainName 111 | Type: A 112 | 113 | Bucket: 114 | Type: AWS::S3::Bucket 115 | Properties: 116 | AccessControl: PublicRead 117 | BucketName: !Ref DomainName 118 | WebsiteConfiguration: 119 | RedirectAllRequestsTo: 120 | HostName: !Sub www.${DomainName} 121 | Protocol: https 122 | 123 | Cluster: 124 | Type: AWS::ECS::Cluster 125 | Properties: 126 | ClusterName: !Sub ${AWS::StackName}-cluster 127 | 128 | HostedZone: 129 | Type: AWS::Route53::HostedZone 130 | Properties: 131 | Name: !Ref DomainName 132 | 133 | Instance: 134 | Type: AWS::EC2::Instance 135 | Properties: 136 | AvailabilityZone: !Select 137 | - 0 138 | - Fn::GetAZs: !Ref AWS::Region 139 | IamInstanceProfile: !Ref InstanceProfile 140 | ImageId: !Ref AmiId 141 | InstanceType: t3a.small 142 | SecurityGroupIds: 143 | - !Ref SecurityGroup 144 | SubnetId: !Ref Subnet1 145 | UserData: 146 | Fn::Base64: !Sub | 147 | #! /usr/bin/env sh 148 | set -o errexit -o xtrace 149 | echo ECS_CLUSTER=${Cluster} >> /etc/ecs/ecs.config 150 | mkfs.xfs /dev/sdz || true 151 | mkdir /ebs 152 | mount /dev/sdz /ebs 153 | /opt/aws/bin/cfn-signal \ 154 | --exit-code $? \ 155 | --region ${AWS::Region} \ 156 | --resource AutoScalingGroup \ 157 | --stack ${AWS::StackName} 158 | Volumes: 159 | - Device: /dev/sdz 160 | VolumeId: !Ref Volume 161 | 162 | InstanceRole: 163 | Type: AWS::IAM::Role 164 | Properties: 165 | AssumeRolePolicyDocument: 166 | Statement: 167 | - Action: 168 | - sts:AssumeRole 169 | Effect: Allow 170 | Principal: 171 | Service: 172 | - ec2.amazonaws.com 173 | Version: 2012-10-17 174 | ManagedPolicyArns: 175 | - arn:aws:iam::aws:policy/service-role/AmazonEC2ContainerServiceforEC2Role 176 | RoleName: !Sub ${AWS::StackName}-instance-role 177 | 178 | InstanceProfile: 179 | Type: AWS::IAM::InstanceProfile 180 | Properties: 181 | InstanceProfileName: !Sub ${AWS::StackName}-instance-profile 182 | Roles: 183 | - !Ref InstanceRole 184 | 185 | InternetGateway: 186 | Type: AWS::EC2::InternetGateway 187 | 188 | Listener: 189 | Type: AWS::ElasticLoadBalancingV2::Listener 190 | Properties: 191 | Certificates: 192 | - CertificateArn: !Ref OriginCertificate 193 | DefaultActions: 194 | - TargetGroupArn: !Ref TargetGroup 195 | Type: forward 196 | LoadBalancerArn: !Ref LoadBalancer 197 | Port: 443 198 | Protocol: HTTPS 199 | 200 | LoadBalancer: 201 | Type: AWS::ElasticLoadBalancingV2::LoadBalancer 202 | Properties: 203 | Name: !Sub ${AWS::StackName}-load-balancer 204 | SecurityGroups: 205 | - !Ref SecurityGroup 206 | Subnets: 207 | - !Ref Subnet1 208 | - !Ref Subnet2 209 | 210 | LogGroup: 211 | Type: AWS::Logs::LogGroup 212 | Properties: 213 | LogGroupName: !Sub ${AWS::StackName}-log-group 214 | RetentionInDays: 30 215 | 216 | OriginCertificate: 217 | Type: AWS::CertificateManager::Certificate 218 | Properties: 219 | DomainName: !Sub origin.${DomainName} 220 | ValidationMethod: DNS 221 | 222 | OriginRecordSet: 223 | Type: AWS::Route53::RecordSet 224 | Properties: 225 | AliasTarget: 226 | DNSName: !GetAtt LoadBalancer.DNSName 227 | HostedZoneId: !GetAtt LoadBalancer.CanonicalHostedZoneID 228 | HostedZoneId: !Ref HostedZone 229 | Name: !Sub origin.${DomainName} 230 | Type: A 231 | 232 | Route: 233 | Type: AWS::EC2::Route 234 | Properties: 235 | DestinationCidrBlock: 0.0.0.0/0 236 | GatewayId: !Ref InternetGateway 237 | RouteTableId: !Ref RouteTable 238 | 239 | RouteTable: 240 | Type: AWS::EC2::RouteTable 241 | Properties: 242 | VpcId: !Ref Vpc 243 | 244 | SecurityGroup: 245 | Type: AWS::EC2::SecurityGroup 246 | Properties: 247 | GroupDescription: Allows everything 248 | GroupName: !Sub ${AWS::StackName}-security-group 249 | SecurityGroupEgress: 250 | CidrIp: 0.0.0.0/0 251 | FromPort: -1 252 | IpProtocol: -1 253 | ToPort: -1 254 | SecurityGroupIngress: 255 | CidrIp: 0.0.0.0/0 256 | FromPort: -1 257 | IpProtocol: -1 258 | ToPort: -1 259 | VpcId: !Ref Vpc 260 | 261 | Service: 262 | Type: AWS::ECS::Service 263 | DependsOn: Listener 264 | Properties: 265 | Cluster: !Ref Cluster 266 | DesiredCount: 1 267 | LoadBalancers: 268 | - ContainerName: !Sub ${AWS::StackName}-container-definition 269 | ContainerPort: !Ref PortNumber 270 | TargetGroupArn: !Ref TargetGroup 271 | ServiceName: !Sub ${AWS::StackName}-service 272 | TaskDefinition: !Ref TaskDefinition 273 | 274 | Subnet1: 275 | Type: AWS::EC2::Subnet 276 | Properties: 277 | AvailabilityZone: !Select 278 | - 0 279 | - Fn::GetAZs: !Ref AWS::Region 280 | CidrBlock: 10.0.1.0/24 281 | MapPublicIpOnLaunch: true 282 | VpcId: !Ref Vpc 283 | 284 | Subnet2: 285 | Type: AWS::EC2::Subnet 286 | Properties: 287 | AvailabilityZone: !Select 288 | - 1 289 | - Fn::GetAZs: !Ref AWS::Region 290 | CidrBlock: 10.0.2.0/24 291 | MapPublicIpOnLaunch: true 292 | VpcId: !Ref Vpc 293 | 294 | SubnetRouteTableAssociation1: 295 | Type: AWS::EC2::SubnetRouteTableAssociation 296 | Properties: 297 | RouteTableId: !Ref RouteTable 298 | SubnetId: !Ref Subnet1 299 | 300 | SubnetRouteTableAssociation2: 301 | Type: AWS::EC2::SubnetRouteTableAssociation 302 | Properties: 303 | RouteTableId: !Ref RouteTable 304 | SubnetId: !Ref Subnet2 305 | 306 | TargetGroup: 307 | Type: AWS::ElasticLoadBalancingV2::TargetGroup 308 | Properties: 309 | HealthCheckPath: /api/ping 310 | Name: !Sub ${AWS::StackName}-target-group 311 | Port: !Ref PortNumber 312 | Protocol: HTTP 313 | TargetType: instance 314 | VpcId: !Ref Vpc 315 | 316 | TaskDefinition: 317 | Type: AWS::ECS::TaskDefinition 318 | Properties: 319 | ContainerDefinitions: 320 | - Command: 321 | - monadoc 322 | - !Sub --client-id=${ClientId} 323 | - !Sub --client-secret=${ClientSecret} 324 | - --database=/ebs/monadoc.sqlite3 325 | - !Sub --discord-url=${DiscordUrl} 326 | - --host=* 327 | - !Sub --port=${PortNumber} 328 | - !Sub --url=https://www.${DomainName} 329 | Essential: true 330 | Image: !Sub taylorfausak/monadoc:${TagName} 331 | LogConfiguration: 332 | LogDriver: awslogs 333 | Options: 334 | awslogs-group: !Ref LogGroup 335 | awslogs-region: !Ref AWS::Region 336 | awslogs-stream-prefix: !Ref TagName 337 | MountPoints: 338 | - ContainerPath: /ebs 339 | SourceVolume: !Sub ${AWS::StackName}-volume 340 | Name: !Sub ${AWS::StackName}-container-definition 341 | PortMappings: 342 | - ContainerPort: !Ref PortNumber 343 | Cpu: 1024 344 | ExecutionRoleArn: !Ref TaskRole 345 | Family: !Sub ${AWS::StackName}-task-definition 346 | Memory: 980 347 | NetworkMode: bridge 348 | Volumes: 349 | - Host: 350 | SourcePath: /ebs 351 | Name: !Sub ${AWS::StackName}-volume 352 | 353 | TaskRole: 354 | Type: AWS::IAM::Role 355 | Properties: 356 | AssumeRolePolicyDocument: 357 | Statement: 358 | - Action: 359 | - sts:AssumeRole 360 | Effect: Allow 361 | Principal: 362 | Service: 363 | - ecs-tasks.amazonaws.com 364 | Version: 2012-10-17 365 | ManagedPolicyArns: 366 | - arn:aws:iam::aws:policy/service-role/AmazonECSTaskExecutionRolePolicy 367 | RoleName: !Sub ${AWS::StackName}-task-role 368 | 369 | Volume: 370 | Type: AWS::EC2::Volume 371 | Properties: 372 | AvailabilityZone: !Select 373 | - 0 374 | - Fn::GetAZs: !Ref AWS::Region 375 | Encrypted: true 376 | Size: 64 377 | 378 | Vpc: 379 | Type: AWS::EC2::VPC 380 | Properties: 381 | CidrBlock: 10.0.0.0/16 382 | EnableDnsHostnames: true 383 | 384 | VpcGatewayAttachment: 385 | Type: AWS::EC2::VPCGatewayAttachment 386 | Properties: 387 | InternetGatewayId: !Ref InternetGateway 388 | VpcId: !Ref Vpc 389 | 390 | WwwCertificate: 391 | Type: AWS::CertificateManager::Certificate 392 | Properties: 393 | DomainName: !Sub www.${DomainName} 394 | ValidationMethod: DNS 395 | 396 | WwwDistribution: 397 | Type: AWS::CloudFront::Distribution 398 | Properties: 399 | DistributionConfig: 400 | Aliases: 401 | - !Sub www.${DomainName} 402 | DefaultCacheBehavior: 403 | AllowedMethods: 404 | - DELETE 405 | - GET 406 | - HEAD 407 | - OPTIONS 408 | - PATCH 409 | - POST 410 | - PUT 411 | CachedMethods: 412 | - GET 413 | - HEAD 414 | - OPTIONS 415 | Compress: false 416 | ForwardedValues: 417 | Cookies: 418 | Forward: all 419 | Headers: 420 | - Accept-Encoding 421 | QueryString: true 422 | TargetOriginId: !Sub origin.${DomainName} 423 | ViewerProtocolPolicy: redirect-to-https 424 | Enabled: true 425 | HttpVersion: http2 426 | Origins: 427 | - CustomOriginConfig: 428 | OriginProtocolPolicy: https-only 429 | OriginSSLProtocols: 430 | - TLSv1.2 431 | DomainName: !Sub origin.${DomainName} 432 | Id: !Sub origin.${DomainName} 433 | ViewerCertificate: 434 | AcmCertificateArn: !Ref WwwCertificate 435 | MinimumProtocolVersion: TLSv1.2_2018 436 | SslSupportMethod: sni-only 437 | 438 | WwwRecordSet: 439 | Type: AWS::Route53::RecordSet 440 | Properties: 441 | AliasTarget: 442 | DNSName: !GetAtt WwwDistribution.DomainName 443 | HostedZoneId: Z2FDTNDATAQYW2 444 | HostedZoneId: !Ref HostedZone 445 | Name: !Sub www.${DomainName} 446 | Type: A 447 | -------------------------------------------------------------------------------- /config/hlint.yaml: -------------------------------------------------------------------------------- 1 | - arguments: 2 | - -XApplicativeDo 3 | - -XBangPatterns 4 | - -XBlockArguments 5 | - -XDataKinds 6 | - -XFlexibleContexts 7 | - -XNamedFieldPuns 8 | - -XNegativeLiterals 9 | - -XNoImplicitPrelude 10 | - -XNumDecimals 11 | - -XNumericUnderscores 12 | - -XOverloadedStrings 13 | - -XScopedTypeVariables 14 | - -XTypeApplications 15 | - extensions: [ { default: false } ] 16 | - flags: [ { default: false } ] 17 | - group: { name: dollar, enabled: true } 18 | - group: { name: generalise, enabled: true } 19 | - ignore: { name: Reduce duplication } 20 | - ignore: { name: Redundant do } 21 | - ignore: { name: Redundant id } 22 | - ignore: { name: Use <$> } 23 | - ignore: { name: Use =<< } 24 | - ignore: { name: Use fmap } 25 | - ignore: { name: Use lambda-case } 26 | -------------------------------------------------------------------------------- /config/stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | columns: 79 2 | indent: 2 3 | language_extensions: 4 | - ApplicativeDo 5 | - BangPatterns 6 | - BlockArguments 7 | - DataKinds 8 | - FlexibleContexts 9 | - NamedFieldPuns 10 | - NegativeLiterals 11 | - NoImplicitPrelude 12 | - NumDecimals 13 | - NumericUnderscores 14 | - OverloadedStrings 15 | - ScopedTypeVariables 16 | - TypeApplications 17 | steps: 18 | - imports: { align: none } 19 | - language_pragmas: 20 | align: false 21 | style: compact_line 22 | - squash: {} 23 | - trailing_whitespace: {} 24 | -------------------------------------------------------------------------------- /data/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tfausak/monadoc-5/5361dd1870072cf2771857adbe92658118ddaa27/data/favicon.ico -------------------------------------------------------------------------------- /data/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tfausak/monadoc-5/5361dd1870072cf2771857adbe92658118ddaa27/data/logo.png -------------------------------------------------------------------------------- /docker/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ubuntu:18.04 2 | RUN apt-get update && apt-get install --assume-yes ca-certificates 3 | COPY data /opt/monadoc/data 4 | COPY ghc-8.10.1 /opt/ghc/8.10.1/lib/ghc-8.10.1 5 | ENV monadoc_datadir /opt/monadoc 6 | COPY monadoc /usr/local/bin/ 7 | -------------------------------------------------------------------------------- /monadoc.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | 3 | name: monadoc 4 | version: 0.2020.9.2 5 | synopsis: Better Haskell documentation. 6 | description: Monadoc provides better Haskell documentation. 7 | 8 | category: Documentation 9 | data-files: 10 | data/favicon.ico 11 | data/logo.png 12 | data/tachyons-4-12-0.css 13 | extra-source-files: 14 | config/brittany.yaml 15 | config/hlint.yaml 16 | config/stylish-haskell.yaml 17 | src/script/brittany.hs 18 | src/script/hlint.hs 19 | src/script/stylish-haskell.hs 20 | README.markdown 21 | license-file: LICENSE.markdown 22 | license: ISC 23 | maintainer: Taylor Fausak 24 | 25 | source-repository head 26 | location: https://github.com/tfausak/monadoc 27 | type: git 28 | 29 | common library 30 | build-depends: 31 | base >= 4.14.0 && < 4.15 32 | , aeson >= 1.4.7 && < 1.6 33 | , async >= 2.2.2 && < 2.3 34 | , bytestring >= 0.10.10 && < 0.11 35 | , Cabal >= 3.2.0 && < 3.3 36 | , containers >= 0.6.2 && < 0.7 37 | , cookie >= 0.4.5 && < 0.5 38 | , cpphs >= 1.20.9 && < 1.21 39 | , cryptonite >= 0.27 && < 0.28 40 | , exceptions >= 0.10.4 && < 0.11 41 | , filepath >= 1.4.2 && < 1.5 42 | , ghc >= 8.10.1 && < 8.11 43 | , ghc-boot-th >= 8.10.1 && < 8.11 44 | , ghc-paths >= 0.1.0 && < 0.2 45 | , ghc-prim >= 0.6.1 && < 0.7 46 | , http-client >= 0.6.4 && < 0.8 47 | , http-client-tls >= 0.3.5 && < 0.4 48 | , http-types >= 0.12.3 && < 0.13 49 | , integer-gmp >= 1.0.3 && < 1.1 50 | , lucid >= 2.9.12 && < 2.10 51 | , network-uri >= 2.6.3 && < 2.7 52 | , random >= 1.1 && < 1.2 53 | , resource-pool >= 0.2.3 && < 0.3 54 | , sqlite-simple >= 0.4.18 && < 0.5 55 | , stm >= 2.5.0 && < 2.6 56 | , tar >= 0.5.1 && < 0.6 57 | , text >= 1.2.3 && < 1.3 58 | , time >= 1.9.3 && < 1.10 59 | , transformers >= 0.5.6 && < 0.6 60 | , uuid >= 1.3.13 && < 1.4 61 | , wai >= 3.2.2 && < 3.3 62 | , warp >= 3.3.12 && < 3.4 63 | , zlib >= 0.6.2 && < 0.7 64 | default-extensions: 65 | -- Keep this in sync with Brittany, HLint, and Stylish Haskell configs. 66 | ApplicativeDo 67 | BangPatterns 68 | BlockArguments 69 | DataKinds 70 | FlexibleContexts 71 | NamedFieldPuns 72 | NegativeLiterals 73 | NoImplicitPrelude 74 | NumDecimals 75 | NumericUnderscores 76 | OverloadedStrings 77 | ScopedTypeVariables 78 | TypeApplications 79 | default-language: Haskell2010 80 | ghc-options: 81 | -Weverything 82 | -Wno-all-missed-specialisations 83 | -Wno-implicit-prelude 84 | -Wno-missing-deriving-strategies 85 | -Wno-missing-export-lists 86 | -Wno-missing-exported-signatures 87 | -Wno-missing-import-lists 88 | -Wno-missing-local-signatures 89 | -Wno-missing-safe-haskell-mode 90 | -Wno-monomorphism-restriction 91 | -Wno-prepositive-qualified-module 92 | -Wno-safe 93 | -Wno-unsafe 94 | 95 | common executable 96 | import: library 97 | 98 | build-depends: monadoc 99 | ghc-options: -rtsopts -threaded -Wno-unused-packages 100 | 101 | library 102 | import: library 103 | 104 | autogen-modules: Paths_monadoc 105 | exposed-modules: 106 | Monadoc 107 | Monadoc.Data.Commit 108 | Monadoc.Data.Migrations 109 | Monadoc.Data.Options 110 | Monadoc.Data.Version 111 | Monadoc.Handler.Account 112 | Monadoc.Handler.Favicon 113 | Monadoc.Handler.GitHubCallback 114 | Monadoc.Handler.Index 115 | Monadoc.Handler.Logo 116 | Monadoc.Handler.LogOut 117 | Monadoc.Handler.Ping 118 | Monadoc.Handler.Robots 119 | Monadoc.Handler.Search 120 | Monadoc.Handler.Tachyons 121 | Monadoc.Handler.Throw 122 | Monadoc.Main 123 | Monadoc.Prelude 124 | Monadoc.Server.Application 125 | Monadoc.Server.Common 126 | Monadoc.Server.Main 127 | Monadoc.Server.Middleware 128 | Monadoc.Server.Router 129 | Monadoc.Server.Settings 130 | Monadoc.Server.Template 131 | Monadoc.Type.App 132 | Monadoc.Type.Binary 133 | Monadoc.Type.Cabal.ModuleName 134 | Monadoc.Type.Cabal.PackageName 135 | Monadoc.Type.Cabal.Version 136 | Monadoc.Type.Cabal.VersionRange 137 | Monadoc.Type.Config 138 | Monadoc.Type.ConfigResult 139 | Monadoc.Type.Context 140 | Monadoc.Type.Etag 141 | Monadoc.Type.GitHub.Login 142 | Monadoc.Type.GitHub.User 143 | Monadoc.Type.GitHub.UserId 144 | Monadoc.Type.Guid 145 | Monadoc.Type.Migration 146 | Monadoc.Type.MigrationMismatch 147 | Monadoc.Type.NotFoundException 148 | Monadoc.Type.Path 149 | Monadoc.Type.Revision 150 | Monadoc.Type.Route 151 | Monadoc.Type.Service 152 | Monadoc.Type.Sha256 153 | Monadoc.Type.Size 154 | Monadoc.Type.TestException 155 | Monadoc.Type.Timestamp 156 | Monadoc.Type.Url 157 | Monadoc.Type.User 158 | Monadoc.Type.WithCallStack 159 | Monadoc.Utility.Cabal 160 | Monadoc.Utility.Console 161 | Monadoc.Utility.Ghc 162 | Monadoc.Utility.Sql 163 | Monadoc.Utility.Time 164 | Monadoc.Utility.Utf8 165 | Monadoc.Worker.Main 166 | hs-source-dirs: src/lib 167 | other-modules: Paths_monadoc 168 | 169 | executable monadoc 170 | import: executable 171 | 172 | hs-source-dirs: src/exe 173 | main-is: Main.hs 174 | 175 | test-suite test 176 | import: executable 177 | 178 | build-depends: hspec >= 2.7.1 && < 2.8 179 | hs-source-dirs: src/test 180 | main-is: Main.hs 181 | other-modules: 182 | Monadoc.Data.CommitSpec 183 | Monadoc.Data.MigrationsSpec 184 | Monadoc.Data.OptionsSpec 185 | Monadoc.Data.VersionSpec 186 | Monadoc.Handler.AccountSpec 187 | Monadoc.Handler.FaviconSpec 188 | Monadoc.Handler.GitHubCallbackSpec 189 | Monadoc.Handler.IndexSpec 190 | Monadoc.Handler.LogoSpec 191 | Monadoc.Handler.LogOutSpec 192 | Monadoc.Handler.PingSpec 193 | Monadoc.Handler.RobotsSpec 194 | Monadoc.Handler.SearchSpec 195 | Monadoc.Handler.TachyonsSpec 196 | Monadoc.Handler.ThrowSpec 197 | Monadoc.MainSpec 198 | Monadoc.Server.ApplicationSpec 199 | Monadoc.Server.CommonSpec 200 | Monadoc.Server.MainSpec 201 | Monadoc.Server.MiddlewareSpec 202 | Monadoc.Server.RouterSpec 203 | Monadoc.Server.SettingsSpec 204 | Monadoc.Server.TemplateSpec 205 | Monadoc.Type.AppSpec 206 | Monadoc.Type.BinarySpec 207 | Monadoc.Type.Cabal.ModuleNameSpec 208 | Monadoc.Type.Cabal.PackageNameSpec 209 | Monadoc.Type.Cabal.VersionRangeSpec 210 | Monadoc.Type.Cabal.VersionSpec 211 | Monadoc.Type.ConfigResultSpec 212 | Monadoc.Type.ConfigSpec 213 | Monadoc.Type.ContextSpec 214 | Monadoc.Type.EtagSpec 215 | Monadoc.Type.GitHub.LoginSpec 216 | Monadoc.Type.GitHub.UserIdSpec 217 | Monadoc.Type.GitHub.UserSpec 218 | Monadoc.Type.GuidSpec 219 | Monadoc.Type.MigrationMismatchSpec 220 | Monadoc.Type.MigrationSpec 221 | Monadoc.Type.NotFoundExceptionSpec 222 | Monadoc.Type.PathSpec 223 | Monadoc.Type.RevisionSpec 224 | Monadoc.Type.RouteSpec 225 | Monadoc.Type.ServiceSpec 226 | Monadoc.Type.Sha256Spec 227 | Monadoc.Type.SizeSpec 228 | Monadoc.Type.TestExceptionSpec 229 | Monadoc.Type.TimestampSpec 230 | Monadoc.Type.UrlSpec 231 | Monadoc.Type.UserSpec 232 | Monadoc.Type.WithCallStackSpec 233 | Monadoc.Utility.CabalSpec 234 | Monadoc.Utility.ConsoleSpec 235 | Monadoc.Utility.GhcSpec 236 | Monadoc.Utility.SqlSpec 237 | Monadoc.Utility.TimeSpec 238 | Monadoc.Utility.Utf8Spec 239 | Monadoc.Worker.MainSpec 240 | MonadocSpec 241 | type: exitcode-stdio-1.0 242 | -------------------------------------------------------------------------------- /src/exe/Main.hs: -------------------------------------------------------------------------------- 1 | import qualified Monadoc 2 | import Monadoc.Prelude 3 | 4 | main :: IO () 5 | main = Monadoc.monadoc 6 | -------------------------------------------------------------------------------- /src/lib/Monadoc.hs: -------------------------------------------------------------------------------- 1 | module Monadoc where 2 | 3 | import qualified Control.Concurrent as Concurrent 4 | import qualified Control.Monad as Monad 5 | import qualified Control.Monad.Catch as Exception 6 | import qualified Data.List.NonEmpty as NonEmpty 7 | import qualified Data.Pool as Pool 8 | import qualified Data.Time as Time 9 | import qualified Database.SQLite.Simple as Sql 10 | import qualified Monadoc.Data.Commit as Commit 11 | import qualified Monadoc.Data.Options as Options 12 | import qualified Monadoc.Data.Version as Version 13 | import qualified Monadoc.Main as Main 14 | import Monadoc.Prelude 15 | import qualified Monadoc.Type.App as App 16 | import qualified Monadoc.Type.Config as Config 17 | import qualified Monadoc.Type.ConfigResult as ConfigResult 18 | import qualified Monadoc.Type.Context as Context 19 | import qualified Monadoc.Utility.Console as Console 20 | import qualified Network.HTTP.Client.TLS as Tls 21 | import qualified System.Console.GetOpt as GetOpt 22 | import qualified System.Environment as Environment 23 | import qualified System.Exit as Exit 24 | import qualified System.IO as IO 25 | 26 | -- | The main app entrypoint. This is what the executable runs. 27 | monadoc :: IO () 28 | monadoc = do 29 | Monad.forM_ [IO.stderr, IO.stdout] <| \h -> do 30 | IO.hSetBuffering h IO.LineBuffering 31 | IO.hSetEncoding h IO.utf8 32 | config <- getConfig 33 | Console.info <| fold 34 | [ "\x1f516 Starting Monadoc version " 35 | , Version.string 36 | , case Commit.hash of 37 | Nothing -> "" 38 | Just hash -> " commit " <> hash 39 | , " ..." 40 | ] 41 | context <- configToContext config 42 | Exception.finally (App.run context Main.run) 43 | <<< Pool.destroyAllResources 44 | <| Context.pool context 45 | 46 | getConfig :: IO Config.Config 47 | getConfig = do 48 | name <- Environment.getProgName 49 | arguments <- Environment.getArgs 50 | case argumentsToConfigResult name arguments of 51 | ConfigResult.Failure errs -> do 52 | traverse_ (IO.hPutStr IO.stderr) errs 53 | Exit.exitFailure 54 | ConfigResult.ExitWith msg -> do 55 | putStr msg 56 | Exit.exitSuccess 57 | ConfigResult.Success msgs config -> do 58 | traverse_ (IO.hPutStr IO.stderr) msgs 59 | pure config 60 | 61 | -- | Parses command-line arguments into a config. 62 | argumentsToConfigResult 63 | :: String 64 | -- ^ The program name, usually from 'Environment.getProgName'. 65 | -> [String] 66 | -- ^ The command-line arguments, usually from 'Environment.getArgs'. 67 | -> ConfigResult.ConfigResult 68 | argumentsToConfigResult name arguments = 69 | let 70 | (funs, args, opts, errs) = 71 | GetOpt.getOpt' GetOpt.Permute Options.options arguments 72 | helpHash = case Commit.hash of 73 | Nothing -> [] 74 | Just hash -> ["commit", hash] 75 | help = GetOpt.usageInfo 76 | (unwords <| [name, "version", Version.string] <> helpHash) 77 | Options.options 78 | versionHash = case Commit.hash of 79 | Nothing -> "" 80 | Just hash -> "-" <> hash 81 | version = Version.string <> versionHash <> "\n" 82 | formatArg arg = "WARNING: argument `" <> arg <> "' not expected\n" 83 | formatOpt opt = "WARNING: option `" <> opt <> "' not recognized\n" 84 | warnings = map formatArg args <> map formatOpt opts 85 | in case NonEmpty.nonEmpty errs of 86 | Just es -> ConfigResult.Failure <| map ("ERROR: " <>) es 87 | Nothing -> case Monad.foldM (|>) Config.initial funs of 88 | Left err -> ConfigResult.Failure <<< pure <| "ERROR: " <> err <> "\n" 89 | Right config -> if Config.help config 90 | then ConfigResult.ExitWith help 91 | else if Config.version config 92 | then ConfigResult.ExitWith version 93 | else ConfigResult.Success warnings config 94 | 95 | -- | Converts a config into a context. This involves acquiring any resources 96 | -- described in the config. 97 | configToContext :: Config.Config -> IO (Context.Context ()) 98 | configToContext config = do 99 | manager <- Tls.newTlsManager 100 | let database = Config.database config 101 | maxResources <- if isInMemory database then pure 1 else getMaxResources 102 | pool <- Pool.createPool 103 | (Sql.open database) 104 | Sql.close 105 | stripeCount 106 | idleTime 107 | maxResources 108 | pure Context.Context 109 | { Context.config = config 110 | , Context.manager = manager 111 | , Context.pool = pool 112 | , Context.request = () 113 | } 114 | 115 | stripeCount :: Int 116 | stripeCount = 1 117 | 118 | idleTime :: Time.NominalDiffTime 119 | idleTime = 60 120 | 121 | getMaxResources :: IO Int 122 | getMaxResources = map (max 1) Concurrent.getNumCapabilities 123 | 124 | isInMemory :: FilePath -> Bool 125 | isInMemory database = case database of 126 | "" -> True 127 | ":memory:" -> True 128 | _ -> False 129 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Data/Commit.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Data.Commit where 2 | 3 | import Monadoc.Prelude 4 | 5 | -- | The Git commit hash this package was built at, if available. Like the 6 | -- version number, you'll probably only need this for diagnostics. 7 | hash :: Maybe String 8 | hash = 9 | -- This looks pretty silly by itself. See src/script/set-commit-hash.hs for 10 | -- an explanation. 11 | Nothing 12 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Data/Migrations.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Data.Migrations where 2 | 3 | import qualified Data.Fixed as Fixed 4 | import qualified Database.SQLite.Simple as Sql 5 | import Monadoc.Prelude 6 | import qualified Monadoc.Type.Migration as Migration 7 | import qualified Monadoc.Type.Timestamp as Timestamp 8 | import qualified Monadoc.Utility.Time as Time 9 | 10 | -- | Collection of migrations to run. The app automatically performs migrations 11 | -- when it starts. They are run ordered by their timestamps. 12 | -- 13 | -- Because an old version of the app may be running when a new version 14 | -- launches, migrations needs to be compatible. Both old and new code must be 15 | -- able to deal with both old and new databases. 16 | migrations :: Set Migration.Migration 17 | migrations = fromList 18 | [ makeMigration (2020, 5, 31, 13, 38, 0) "select 1" 19 | , makeMigration 20 | (2020, 6, 2, 13, 43, 0) 21 | " create table blobs ( \ 22 | \octets blob not null , \ 23 | \sha256 text not null primary key , \ 24 | \size integer not null )" 25 | , makeMigration 26 | (2020, 6, 2, 13, 50, 0) 27 | " create table cache ( \ 28 | \etag text not null , \ 29 | \sha256 text not null , \ 30 | \url text not null primary key )" 31 | , makeMigration 32 | (2020, 6, 10, 19, 46, 0) 33 | "create table files (\ 34 | \digest text not null, \ 35 | \name text primary key)" 36 | , makeMigration 37 | (2020, 6, 14, 12, 31, 0) 38 | "create table users (\ 39 | \guid text not null unique, \ 40 | \id integer not null primary key, \ 41 | \login text not null, \ 42 | \token text not null)" 43 | , makeMigration 44 | (2020, 6, 20, 8, 43, 0) 45 | "create table preferred_versions (\ 46 | \package_name text not null primary key, \ 47 | \version_range text not null)" 48 | , makeMigration 49 | (2020, 8, 4, 21, 58, 0) 50 | "create table processed_files (\ 51 | \path text primary key, \ 52 | \sha256 text not null, \ 53 | \timestamp text not null)" 54 | , makeMigration 55 | (2020, 8, 10, 21, 7, 0) 56 | "create table exposed_modules (\ 57 | \package text not null, \ 58 | \version text not null, \ 59 | \revision integer not null, \ 60 | \module text not null, \ 61 | \unique (package, version, revision, module))" 62 | , makeMigration 63 | (2020, 8, 14, 9, 58, 0) 64 | "create table exposed_modules2 (\ 65 | \package text not null, \ 66 | \version text not null, \ 67 | \revision integer not null, \ 68 | \module text not null, \ 69 | \file text, \ 70 | \unique (package, version, revision, module))" 71 | , makeMigration (2020, 8, 15, 9, 50, 0) "drop table exposed_modules" 72 | , makeMigration (2020, 8, 15, 9, 51, 0) "drop table exposed_modules2" 73 | , makeMigration 74 | (2020, 8, 15, 9, 53, 0) 75 | "create table exposed_modules (\ 76 | \package text not null, \ 77 | \version text not null, \ 78 | \revision integer not null, \ 79 | \module text not null, \ 80 | \file text, \ 81 | \parsed boolean not null default false, \ 82 | \unique (package, version, revision, module))" 83 | , makeMigration 84 | (2020, 8, 24, 9, 1, 0) 85 | "delete from processed_files where path like 'd/%'" 86 | , makeMigration 87 | (2020, 8, 24, 9, 2, 0) 88 | "update exposed_modules set parsed = false" 89 | , makeMigration 90 | (2020, 8, 24, 9, 3, 0) 91 | "create table exported_identifiers (\ 92 | \package text not null, \ 93 | \version text not null, \ 94 | \revision integer not null, \ 95 | \module text not null, \ 96 | \identifier text not null, \ 97 | \unique (package, version, revision, module, identifier))" 98 | ] 99 | 100 | makeMigration 101 | :: (Integer, Int, Int, Int, Int, Fixed.Pico) 102 | -> Sql.Query 103 | -> Migration.Migration 104 | makeMigration (year, month, day, hour, minute, second) query = 105 | Migration.Migration 106 | { Migration.query = query 107 | , Migration.timestamp = 108 | Timestamp.fromUtcTime <| Time.utcTime year month day hour minute second 109 | } 110 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Data/Options.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Data.Options where 2 | 3 | import qualified Data.List as List 4 | import qualified Data.Text as Text 5 | import Monadoc.Prelude 6 | import qualified Monadoc.Type.Config as Config 7 | import qualified Monadoc.Type.Service as Service 8 | import qualified Network.Wai.Handler.Warp as Warp 9 | import qualified System.Console.GetOpt as GetOpt 10 | 11 | type Option = GetOpt.OptDescr (Config.Config -> Either String Config.Config) 12 | 13 | -- | Collection of command-line options. Run the app with @--help@ to see what 14 | -- they are. 15 | options :: [Option] 16 | options = 17 | [ clientIdOption 18 | , clientSecretOption 19 | , databaseOption 20 | , discordUrlOption 21 | , hackageUrlOption 22 | , helpOption 23 | , hostOption 24 | , portOption 25 | , servicesOption 26 | , urlOption 27 | , versionOption 28 | ] 29 | 30 | clientIdOption :: Option 31 | clientIdOption = 32 | option 33 | [] 34 | ["client-id"] 35 | ("Sets the OAuth application client ID. Defaults to " 36 | <> show (Config.clientId Config.initial) 37 | <> " which is appropriate for development." 38 | ) 39 | <<< argument "STRING" 40 | <| \clientId config -> Right config { Config.clientId = clientId } 41 | 42 | clientSecretOption :: Option 43 | clientSecretOption = 44 | option 45 | [] 46 | ["client-secret"] 47 | ("Sets the OAuth application client secret. Defaults to " 48 | <> show (Config.clientSecret Config.initial) 49 | <> "." 50 | ) 51 | <<< argument "STRING" 52 | <| \clientSecret config -> 53 | Right config { Config.clientSecret = clientSecret } 54 | 55 | databaseOption :: Option 56 | databaseOption = 57 | option 58 | [] 59 | ["database"] 60 | ("Sets the SQLite database file. Set this to \":memory:\" to use an \ 61 | \in-memory database. Defaults to " 62 | <> show (Config.database Config.initial) 63 | <> "." 64 | ) 65 | <<< argument "FILE" 66 | <| \database config -> Right config { Config.database = database } 67 | 68 | discordUrlOption :: Option 69 | discordUrlOption = 70 | option 71 | [] 72 | ["discord-url"] 73 | ("Sets the Discord webhook URL. Defaults to " 74 | <> show (Config.discordUrl Config.initial) 75 | <> " which will disable exception reporting." 76 | ) 77 | <<< argument "URL" 78 | <| \discordUrl config -> Right config { Config.discordUrl = discordUrl } 79 | 80 | hackageUrlOption :: Option 81 | hackageUrlOption = 82 | option 83 | [] 84 | ["hackage-url"] 85 | ("Sets the Hackage base URL. Defaults to " 86 | <> show (Config.hackageUrl Config.initial) 87 | <> "." 88 | ) 89 | <<< argument "URL" 90 | <| \hackageUrl config -> Right config { Config.hackageUrl = hackageUrl } 91 | 92 | helpOption :: Option 93 | helpOption = 94 | option ['h'] ["help"] "Shows this help message and exits." 95 | <<< GetOpt.NoArg 96 | <| \config -> Right config { Config.help = True } 97 | 98 | hostOption :: Option 99 | hostOption = 100 | option 101 | [] 102 | ["host"] 103 | ("Sets the host that the server binds on. Use '*' for other machines to \ 104 | \see your server. Defaults to " 105 | <> showHost (Config.host Config.initial) 106 | <> "." 107 | ) 108 | <<< argument "STRING" 109 | <| \host config -> Right config { Config.host = fromString host } 110 | 111 | showHost :: Warp.HostPreference -> String 112 | showHost host = case host of 113 | "*" -> "\"*\"" 114 | "*4" -> "\"*4\"" 115 | "!4" -> "\"!4\"" 116 | "*6" -> "\"*6\"" 117 | "!6" -> "\"!6\"" 118 | _ -> drop 5 <| show host 119 | 120 | portOption :: Option 121 | portOption = 122 | option 123 | [] 124 | ["port"] 125 | ("Sets the port that the server binds on. Defaults to " 126 | <> showPort (Config.port Config.initial) 127 | <> "." 128 | ) 129 | <<< argument "NUMBER" 130 | <| \rawPort config -> case read rawPort of 131 | Nothing -> Left <| "invalid port: " <> show rawPort 132 | Just port -> Right config { Config.port = port } 133 | 134 | showPort :: Warp.Port -> String 135 | showPort = show <<< show 136 | 137 | servicesOption :: Option 138 | servicesOption = 139 | option 140 | [] 141 | ["services"] 142 | ("Sets the services to run. Separate services with commas. Defaults to " 143 | <> showServices (Config.services Config.initial) 144 | <> " which is all the services." 145 | ) 146 | <<< argument "STRING" 147 | <| \rawServices config -> case readServices rawServices of 148 | Nothing -> Left <| "invalid services: " <> show rawServices 149 | Just services -> Right config { Config.services = services } 150 | 151 | readServices :: String -> Maybe (Set Service.Service) 152 | readServices string = do 153 | list <- traverse readService <<< Text.splitOn "," <| fromString string 154 | guard <| present list 155 | let set = fromList list 156 | guard <| length set == length list 157 | pure set 158 | 159 | readService :: Text -> Maybe Service.Service 160 | readService text = case text of 161 | "server" -> Just Service.Server 162 | "worker" -> Just Service.Worker 163 | _ -> Nothing 164 | 165 | showServices :: Set Service.Service -> String 166 | showServices = show <<< List.intercalate "," <<< map showService <<< toList 167 | 168 | showService :: Service.Service -> String 169 | showService service = case service of 170 | Service.Server -> "server" 171 | Service.Worker -> "worker" 172 | 173 | urlOption :: Option 174 | urlOption = 175 | option 176 | [] 177 | ["url"] 178 | ("Sets the base URL that the server is available at. Defaults to " 179 | <> show (Config.url Config.initial) 180 | <> "." 181 | ) 182 | <<< argument "URL" 183 | <| \url config -> Right config { Config.url = url } 184 | 185 | versionOption :: Option 186 | versionOption = 187 | option ['v'] ["version"] "Shows the version number and exits." 188 | <<< GetOpt.NoArg 189 | <| \config -> Right config { Config.version = True } 190 | 191 | option 192 | :: String -> [String] -> String -> GetOpt.ArgDescr a -> GetOpt.OptDescr a 193 | option c s = flip <| GetOpt.Option c s 194 | 195 | argument :: String -> (String -> a) -> GetOpt.ArgDescr a 196 | argument = flip GetOpt.ReqArg 197 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Data/Version.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Data.Version where 2 | 3 | import qualified Data.Version as Version 4 | import Monadoc.Prelude 5 | import qualified Paths_monadoc as Package 6 | 7 | -- | The canonical string representation of the 'version'. 8 | string :: String 9 | string = Version.showVersion version 10 | 11 | -- | This package's version number. Usually you won't need this at run time, 12 | -- but it can be useful for error messages or diagnostics. 13 | version :: Version.Version 14 | version = Package.version 15 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Handler/Account.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.Account where 2 | 3 | import qualified Control.Monad.Trans.Reader as Reader 4 | import qualified Data.Map as Map 5 | import qualified Data.Text as Text 6 | import qualified Lucid as H 7 | import Monadoc.Prelude 8 | import qualified Monadoc.Server.Common as Common 9 | import qualified Monadoc.Server.Router as Router 10 | import qualified Monadoc.Server.Template as Template 11 | import qualified Monadoc.Type.App as App 12 | import qualified Monadoc.Type.Config as Config 13 | import qualified Monadoc.Type.Context as Context 14 | import qualified Monadoc.Type.Route as Route 15 | import qualified Monadoc.Utility.Utf8 as Utf8 16 | import qualified Network.HTTP.Types as Http 17 | import qualified Network.Wai as Wai 18 | 19 | handle :: App.App Wai.Request Wai.Response 20 | handle = do 21 | config <- Reader.asks Context.config 22 | let headers = Common.defaultHeaders config 23 | maybeUser <- Common.getCookieUser 24 | loginUrl <- Common.makeLoginUrl 25 | pure <| case maybeUser of 26 | Nothing -> 27 | Common.statusResponse Http.found302 28 | <| Map.insert Http.hLocation (Utf8.fromText loginUrl) headers 29 | Just _ -> 30 | Common.htmlResponse Http.ok200 headers 31 | <<< Template.makeHtmlWith config maybeUser loginUrl 32 | <<< H.form_ 33 | [ H.method_ "post" 34 | , H.action_ <| Router.renderAbsoluteRoute config Route.LogOut 35 | ] 36 | <<< H.p_ 37 | <| do 38 | "You are logged in. You can manage your " 39 | H.a_ 40 | [ H.href_ 41 | <<< Text.pack 42 | <| "https://github.com/settings/connections/applications/" 43 | <> Config.clientId config 44 | ] 45 | "OAuth application" 46 | " access on GitHub. Or you can " 47 | H.input_ 48 | [ H.type_ "submit" 49 | , H.value_ "log out" 50 | , H.class_ "bg-inherit bn input-reset pa0 pointer red underline" 51 | ] 52 | " of Monadoc." 53 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Handler/Favicon.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.Favicon where 2 | 3 | import qualified Monadoc.Server.Common as Common 4 | import qualified Monadoc.Type.App as App 5 | import qualified Network.Wai as Wai 6 | 7 | import Prelude () 8 | -- import Monadoc.Prelude 9 | 10 | handle :: App.App request Wai.Response 11 | handle = Common.simpleFileResponse "favicon.ico" "image/x-icon" 12 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Handler/GitHubCallback.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.GitHubCallback where 2 | 3 | import qualified Control.Monad as Monad 4 | import qualified Control.Monad.Catch as Exception 5 | import qualified Control.Monad.Trans.Class as Trans 6 | import qualified Control.Monad.Trans.Reader as Reader 7 | import qualified Data.Aeson as Aeson 8 | import qualified Data.ByteString as ByteString 9 | import qualified Data.ByteString.Lazy as LazyByteString 10 | import qualified Data.Map as Map 11 | import qualified Data.Maybe as Maybe 12 | import qualified Data.Text as Text 13 | import qualified Database.SQLite.Simple as Sql 14 | import Monadoc.Prelude 15 | import qualified Monadoc.Server.Common as Common 16 | import qualified Monadoc.Server.Settings as Settings 17 | import qualified Monadoc.Type.App as App 18 | import qualified Monadoc.Type.Config as Config 19 | import qualified Monadoc.Type.Context as Context 20 | import qualified Monadoc.Type.GitHub.User as GHUser 21 | import qualified Monadoc.Type.Guid as Guid 22 | import qualified Monadoc.Type.User as User 23 | import qualified Monadoc.Type.WithCallStack as WithCallStack 24 | import qualified Monadoc.Utility.Utf8 as Utf8 25 | import qualified Network.HTTP.Client as Client 26 | import qualified Network.HTTP.Types as Http 27 | import qualified Network.HTTP.Types.Header as Http 28 | import qualified Network.Wai as Wai 29 | import qualified System.Random as Random 30 | 31 | handle :: App.App Wai.Request Wai.Response 32 | handle = do 33 | code <- getCode 34 | token <- getToken code 35 | user <- getUser token 36 | guid <- upsertUser token user 37 | 38 | cookie <- Common.makeCookie guid 39 | redirect <- getRedirect 40 | config <- Reader.asks Context.config 41 | pure 42 | <<< Common.statusResponse Http.found302 43 | <<< Map.insert Http.hLocation redirect 44 | <<< Map.insert Http.hSetCookie (Common.renderCookie cookie) 45 | <| Common.defaultHeaders config 46 | 47 | getCode :: App.App Wai.Request ByteString.ByteString 48 | getCode = do 49 | request <- Reader.asks Context.request 50 | case lookup "code" <| Wai.queryString request of 51 | Just (Just code) -> pure code 52 | _ -> WithCallStack.throw <| NoCodeProvided request 53 | 54 | newtype NoCodeProvided 55 | = NoCodeProvided Wai.Request 56 | deriving Show 57 | 58 | instance Exception.Exception NoCodeProvided 59 | 60 | getToken :: ByteString.ByteString -> App.App request Text.Text 61 | getToken code = do 62 | context <- Reader.ask 63 | initialRequest <- Client.parseRequest 64 | "https://github.com/login/oauth/access_token" 65 | let 66 | config = Context.config context 67 | request = Client.urlEncodedBody 68 | [ ("client_id", Utf8.fromString <| Config.clientId config) 69 | , ("client_secret", Utf8.fromString <| Config.clientSecret config) 70 | , ("code", code) 71 | ] 72 | initialRequest 73 | response <- Trans.lift <<< Client.httpLbs request <| Context.manager context 74 | case 75 | lookup "access_token" 76 | <<< Http.parseQueryText 77 | <<< LazyByteString.toStrict 78 | <| Client.responseBody response 79 | of 80 | Just (Just token) -> pure token 81 | _ -> WithCallStack.throw <| TokenRequestFailed request response 82 | 83 | data TokenRequestFailed 84 | = TokenRequestFailed Client.Request (Client.Response LazyByteString.ByteString) 85 | deriving Show 86 | 87 | instance Exception.Exception TokenRequestFailed 88 | 89 | getUser :: Text.Text -> App.App request GHUser.User 90 | getUser token = do 91 | context <- Reader.ask 92 | initialRequest <- Client.parseRequest "https://api.github.com/user" 93 | let 94 | request = initialRequest 95 | { Client.requestHeaders = 96 | [ (Http.hAuthorization, "Bearer " <> Utf8.fromText token) 97 | , (Http.hUserAgent, Settings.serverName) 98 | ] 99 | } 100 | response <- Trans.lift <<< Client.httpLbs request <| Context.manager context 101 | case Aeson.eitherDecode <| Client.responseBody response of 102 | Right user -> pure user 103 | Left message -> 104 | WithCallStack.throw <| UserRequestFailed request response message 105 | 106 | data UserRequestFailed 107 | = UserRequestFailed Client.Request (Client.Response LazyByteString.ByteString) String 108 | deriving Show 109 | 110 | instance Exception.Exception UserRequestFailed 111 | 112 | upsertUser :: Text.Text -> GHUser.User -> App.App request Guid.Guid 113 | upsertUser token ghUser = do 114 | guid <- Trans.lift <| Random.getStdRandom Guid.random 115 | let 116 | user = User.User 117 | { User.guid = guid 118 | , User.id = GHUser.id ghUser 119 | , User.login = GHUser.login ghUser 120 | , User.token = token 121 | } 122 | App.sql_ 123 | "insert into users (guid, id, login, token) values (?, ?, ?, ?) \ 124 | \on conflict (id) do update set \ 125 | \login = excluded.login, token = excluded.token" 126 | user 127 | rows <- App.sql "select guid from users where id = ?" [User.id user] 128 | case rows of 129 | only : _ -> pure <| Sql.fromOnly only 130 | _ -> WithCallStack.throw <| UserUpsertFailed user 131 | 132 | newtype UserUpsertFailed 133 | = UserUpsertFailed User.User 134 | deriving Show 135 | 136 | instance Exception.Exception UserUpsertFailed 137 | 138 | getRedirect :: App.App Wai.Request ByteString.ByteString 139 | getRedirect = 140 | Reader.asks 141 | <| Maybe.fromMaybe "/" 142 | <<< Monad.join 143 | <<< lookup "redirect" 144 | <<< Wai.queryString 145 | <<< Context.request 146 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Handler/Index.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.Index where 2 | 3 | import qualified Control.Monad.Trans.Reader as Reader 4 | import qualified Lucid as H 5 | import Monadoc.Prelude 6 | import qualified Monadoc.Server.Common as Common 7 | import qualified Monadoc.Server.Template as Template 8 | import qualified Monadoc.Type.App as App 9 | import qualified Monadoc.Type.Context as Context 10 | import qualified Network.HTTP.Types as Http 11 | import qualified Network.Wai as Wai 12 | 13 | handle :: App.App Wai.Request Wai.Response 14 | handle = do 15 | context <- Reader.ask 16 | maybeUser <- Common.getCookieUser 17 | 18 | let config = Context.config context 19 | loginUrl <- Common.makeLoginUrl 20 | pure 21 | <<< Common.htmlResponse Http.ok200 (Common.defaultHeaders config) 22 | <<< Template.makeHtmlWith config maybeUser loginUrl 23 | <| H.p_ "\x1f516 Better Haskell documentation." 24 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Handler/LogOut.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.LogOut where 2 | 3 | import qualified Control.Monad.Trans.Reader as Reader 4 | import qualified Data.Map as Map 5 | import qualified Data.UUID as Uuid 6 | import Monadoc.Prelude 7 | import qualified Monadoc.Server.Common as Common 8 | import qualified Monadoc.Server.Router as Router 9 | import qualified Monadoc.Type.App as App 10 | import qualified Monadoc.Type.Context as Context 11 | import qualified Monadoc.Type.Guid as Guid 12 | import qualified Monadoc.Type.Route as Route 13 | import qualified Monadoc.Utility.Time as Time 14 | import qualified Monadoc.Utility.Utf8 as Utf8 15 | import qualified Network.HTTP.Types as Http 16 | import qualified Network.HTTP.Types.Header as Http 17 | import qualified Network.Wai as Wai 18 | import qualified Web.Cookie as Cookie 19 | 20 | handle :: App.App Wai.Request Wai.Response 21 | handle = do 22 | config <- Reader.asks Context.config 23 | cookie <- Common.makeCookie <| Guid.fromUuid Uuid.nil 24 | let 25 | headers = Map.union (Common.defaultHeaders config) <| Map.fromList 26 | [ ( Http.hLocation 27 | , Utf8.fromText <| Router.renderAbsoluteRoute config Route.Index 28 | ) 29 | , ( Http.hSetCookie 30 | , Common.renderCookie cookie 31 | { Cookie.setCookieExpires = Just <| Time.utcTime 2000 1 1 0 0 0 32 | } 33 | ) 34 | ] 35 | pure <| Common.statusResponse Http.found302 headers 36 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Handler/Logo.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.Logo where 2 | 3 | import qualified Monadoc.Server.Common as Common 4 | import qualified Monadoc.Type.App as App 5 | import qualified Network.Wai as Wai 6 | 7 | import Prelude () 8 | -- import Monadoc.Prelude 9 | 10 | handle :: App.App request Wai.Response 11 | handle = Common.simpleFileResponse "logo.png" "image/png" 12 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Handler/Ping.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.Ping where 2 | 3 | import qualified Control.Monad as Monad 4 | import qualified Control.Monad.Trans.Reader as Reader 5 | import qualified Database.SQLite.Simple as Sql 6 | import Monadoc.Prelude 7 | import qualified Monadoc.Server.Common as Common 8 | import qualified Monadoc.Type.App as App 9 | import qualified Monadoc.Type.Context as Context 10 | import qualified Network.HTTP.Types as Http 11 | import qualified Network.Wai as Wai 12 | 13 | handle :: App.App request Wai.Response 14 | handle = do 15 | rows <- App.sql "select 1" () 16 | Monad.guard <| rows == [Sql.Only (1 :: Int)] 17 | config <- Reader.asks Context.config 18 | pure <<< Common.statusResponse Http.ok200 <| Common.defaultHeaders config 19 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Handler/Robots.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.Robots where 2 | 3 | import qualified Control.Monad.Trans.Reader as Reader 4 | import Monadoc.Prelude 5 | import qualified Monadoc.Server.Common as Common 6 | import qualified Monadoc.Type.App as App 7 | import qualified Monadoc.Type.Context as Context 8 | import qualified Network.HTTP.Types as Http 9 | import qualified Network.Wai as Wai 10 | 11 | handle :: App.App request Wai.Response 12 | handle = do 13 | config <- Reader.asks Context.config 14 | pure 15 | <<< Common.stringResponse Http.ok200 (Common.defaultHeaders config) 16 | <| unlines ["User-agent: *", "Disallow:"] 17 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Handler/Search.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.Search where 2 | 3 | import qualified Control.Monad.Trans.Reader as Reader 4 | import qualified Lucid as H 5 | import Monadoc.Prelude 6 | import qualified Monadoc.Server.Common as Common 7 | import qualified Monadoc.Server.Template as Template 8 | import qualified Monadoc.Type.App as App 9 | import qualified Monadoc.Type.Context as Context 10 | import qualified Monadoc.Utility.Utf8 as Utf8 11 | import qualified Network.HTTP.Types as Http 12 | import qualified Network.Wai as Wai 13 | 14 | handle :: App.App Wai.Request Wai.Response 15 | handle = do 16 | context <- Reader.ask 17 | maybeUser <- Common.getCookieUser 18 | let 19 | query = 20 | case lookup "query" <<< Wai.queryString <| Context.request context of 21 | Just (Just byteString) -> Utf8.toText byteString 22 | _ -> "" 23 | 24 | let config = Context.config context 25 | loginUrl <- Common.makeLoginUrl 26 | pure 27 | <<< Common.htmlResponse Http.ok200 (Common.defaultHeaders config) 28 | <<< Template.makeHtmlWith config maybeUser loginUrl 29 | <<< H.p_ 30 | <| do 31 | "Your query was " 32 | H.code_ <| H.toHtml query 33 | " but search is not implemented yet." 34 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Handler/Tachyons.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.Tachyons where 2 | 3 | import qualified Monadoc.Server.Common as Common 4 | import qualified Monadoc.Type.App as App 5 | import qualified Network.Wai as Wai 6 | 7 | import Prelude () 8 | -- import Monadoc.Prelude 9 | 10 | handle :: App.App request Wai.Response 11 | handle = 12 | Common.simpleFileResponse "tachyons-4-12-0.css" "text/css;charset=utf-8" 13 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Handler/Throw.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.Throw where 2 | 3 | import qualified Monadoc.Type.App as App 4 | import qualified Monadoc.Type.TestException as TestException 5 | import qualified Monadoc.Type.WithCallStack as WithCallStack 6 | 7 | import Prelude () 8 | -- import Monadoc.Prelude 9 | 10 | handle :: App.App request result 11 | handle = WithCallStack.throw TestException.TestException 12 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Main.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Main where 2 | 3 | import qualified Control.Concurrent.Async as Async 4 | import qualified Control.Monad as Monad 5 | import qualified Control.Monad.Catch as Exception 6 | import qualified Control.Monad.Trans.Class as Trans 7 | import qualified Control.Monad.Trans.Reader as Reader 8 | import qualified Database.SQLite.Simple as Sql 9 | import qualified Monadoc.Data.Migrations as Migrations 10 | import Monadoc.Prelude 11 | import qualified Monadoc.Server.Main as Server 12 | import qualified Monadoc.Type.App as App 13 | import qualified Monadoc.Type.Config as Config 14 | import qualified Monadoc.Type.Context as Context 15 | import qualified Monadoc.Type.Migration as Migration 16 | import qualified Monadoc.Type.MigrationMismatch as MigrationMismatch 17 | import qualified Monadoc.Type.Service as Service 18 | import qualified Monadoc.Type.Sha256 as Sha256 19 | import qualified Monadoc.Type.Timestamp as Timestamp 20 | import qualified Monadoc.Type.WithCallStack as WithCallStack 21 | import qualified Monadoc.Utility.Console as Console 22 | import qualified Monadoc.Utility.Time as Time 23 | import qualified Monadoc.Worker.Main as Worker 24 | 25 | run :: App.App request () 26 | run = do 27 | runMigrations 28 | context <- Reader.ask 29 | Trans.lift 30 | <<< Async.mapConcurrently_ (App.run context <<< runService) 31 | <<< Config.services 32 | <| Context.config context 33 | 34 | runService :: Service.Service -> App.App request () 35 | runService service = case service of 36 | Service.Server -> Server.run 37 | Service.Worker -> Worker.run 38 | 39 | runMigrations :: App.App request () 40 | runMigrations = do 41 | Console.info "Running migrations ..." 42 | App.sql_ "pragma journal_mode = wal" () 43 | App.sql_ 44 | "create table if not exists migrations (\ 45 | \iso8601 text not null primary key, \ 46 | \sha256 text not null)" 47 | () 48 | traverse_ ensureMigration Migrations.migrations 49 | 50 | ensureMigration :: Migration.Migration -> App.App request () 51 | ensureMigration migration = do 52 | maybeDigest <- getDigest <| Migration.timestamp migration 53 | case maybeDigest of 54 | Nothing -> runMigration migration 55 | Just digest -> checkDigest migration digest 56 | 57 | getDigest :: Timestamp.Timestamp -> App.App request (Maybe Sha256.Sha256) 58 | getDigest timestamp = do 59 | rows <- App.sql "select sha256 from migrations where iso8601 = ?" [timestamp] 60 | pure <| case rows of 61 | [] -> Nothing 62 | Sql.Only sha256 : _ -> Just sha256 63 | 64 | runMigration :: Migration.Migration -> App.App request () 65 | runMigration migration = do 66 | Console.info <| unwords 67 | [ "Running migration" 68 | , Time.format "%Y-%m-%dT%H:%M:%S%3QZ" 69 | <<< Timestamp.toUtcTime 70 | <| Migration.timestamp migration 71 | , "..." 72 | ] 73 | App.sql_ (Migration.query migration) () 74 | App.sql_ "insert into migrations (iso8601, sha256) values (?, ?)" migration 75 | 76 | checkDigest 77 | :: Exception.MonadThrow m => Migration.Migration -> Sha256.Sha256 -> m () 78 | checkDigest migration expectedSha256 = do 79 | let actualSha256 = Migration.sha256 migration 80 | Monad.when (actualSha256 /= expectedSha256) <| WithCallStack.throw 81 | MigrationMismatch.MigrationMismatch 82 | { MigrationMismatch.actual = actualSha256 83 | , MigrationMismatch.expected = expectedSha256 84 | , MigrationMismatch.timestamp = Migration.timestamp migration 85 | } 86 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Prelude.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Prelude 2 | ( Control.Applicative.Applicative 3 | , Control.Applicative.pure 4 | , Control.Exception.Exception 5 | , Control.Exception.SomeException(SomeException) 6 | , Control.Exception.displayException 7 | , Control.Exception.evaluate 8 | , Control.Exception.fromException 9 | , Control.Exception.toException 10 | , Control.Monad.Monad 11 | , Control.Monad.forever 12 | , Control.Monad.guard 13 | , Control.Monad.join 14 | , Control.Monad.unless 15 | , Control.Monad.when 16 | , Control.Monad.Catch.MonadThrow 17 | , Control.Monad.Catch.MonadCatch 18 | , Control.Monad.Catch.bracket 19 | , Control.Monad.Catch.catch 20 | , Control.Monad.Catch.finally 21 | , Control.Monad.Catch.handle 22 | , Control.Monad.Catch.try 23 | , Control.Monad.Fail.MonadFail 24 | , Control.Monad.Fail.fail 25 | , Control.Monad.IO.Class.MonadIO 26 | , Control.Monad.Trans.Class.MonadTrans 27 | , Control.Monad.Trans.Class.lift 28 | , Control.Monad.Trans.Except.ExceptT 29 | , Control.Monad.Trans.Except.runExceptT 30 | , Control.Monad.Trans.Maybe.MaybeT 31 | , Control.Monad.Trans.Maybe.runMaybeT 32 | , Control.Monad.Trans.Reader.ReaderT 33 | , Control.Monad.Trans.Reader.runReaderT 34 | , Control.Monad.Trans.State.StateT 35 | , Control.Monad.Trans.State.runStateT 36 | , Control.Monad.Trans.Writer.WriterT 37 | , Control.Monad.Trans.Writer.runWriterT 38 | , Data.Bool.Bool(False, True) 39 | , Data.Bool.not 40 | , Data.Bool.otherwise 41 | , (Data.Bool.&&) 42 | , (Data.Bool.||) 43 | , Data.ByteString.ByteString 44 | , Data.Char.Char 45 | , Data.Data.Data 46 | , Data.Either.Either(Left, Right) 47 | , Data.Either.either 48 | , Data.Eq.Eq 49 | , (Data.Eq./=) 50 | , (Data.Eq.==) 51 | , Data.Fixed.Fixed 52 | , Data.Foldable.Foldable 53 | , Data.Foldable.all 54 | , Data.Foldable.any 55 | , Data.Foldable.elem 56 | , Data.Foldable.fold 57 | , Data.Foldable.foldl 58 | , Data.Foldable.foldMap 59 | , Data.Foldable.foldr 60 | , Data.Foldable.for_ 61 | , Data.Foldable.length 62 | , Data.Foldable.notElem 63 | , Data.Foldable.sequence_ 64 | , Data.Foldable.toList 65 | , Data.Foldable.traverse_ 66 | , Data.Function.flip 67 | , Data.Functor.Functor 68 | , Data.Functor.void 69 | , Data.Functor.Identity.Identity 70 | , Data.Functor.Identity.runIdentity 71 | , Data.Int.Int 72 | , Data.Int.Int8 73 | , Data.Int.Int16 74 | , Data.Int.Int32 75 | , Data.Int.Int64 76 | , Data.List.break 77 | , Data.List.cycle 78 | , Data.List.drop 79 | , Data.List.dropWhile 80 | , Data.List.filter 81 | , Data.List.repeat 82 | , Data.List.replicate 83 | , Data.List.reverse 84 | , Data.List.span 85 | , Data.List.splitAt 86 | , Data.List.take 87 | , Data.List.takeWhile 88 | , Data.List.unzip 89 | , Data.List.zip 90 | , Data.List.zipWith 91 | , Data.List.NonEmpty.NonEmpty 92 | , Data.Map.Map 93 | , Data.Maybe.Maybe(Nothing, Just) 94 | , Data.Maybe.maybe 95 | , Data.Monoid.Monoid 96 | , Data.Monoid.mempty 97 | , Data.Ord.Ord 98 | , Data.Ord.Ordering(LT, EQ, GT) 99 | , Data.Ord.compare 100 | , Data.Ord.comparing 101 | , Data.Ord.max 102 | , Data.Ord.min 103 | , (Data.Ord.<) 104 | , (Data.Ord.<=) 105 | , (Data.Ord.>) 106 | , (Data.Ord.>=) 107 | , Data.Ratio.Ratio 108 | , Data.Ratio.Rational 109 | , Data.Ratio.denominator 110 | , Data.Ratio.numerator 111 | , Data.Semigroup.Semigroup 112 | , (Data.Semigroup.<>) 113 | , Data.Set.Set 114 | , Data.String.IsString 115 | , Data.String.String 116 | , Data.String.fromString 117 | , Data.String.lines 118 | , Data.String.unlines 119 | , Data.String.unwords 120 | , Data.String.words 121 | , Data.Text.Text 122 | , Data.Time.UTCTime 123 | , Data.Traversable.Traversable 124 | , Data.Traversable.for 125 | , Data.Traversable.sequence 126 | , Data.Traversable.traverse 127 | , Data.Tuple.curry 128 | , Data.Tuple.fst 129 | , Data.Tuple.snd 130 | , Data.Tuple.uncurry 131 | , Data.Typeable.Proxy(Proxy) 132 | , Data.Typeable.Typeable 133 | , Data.Typeable.cast 134 | , Data.UUID.UUID 135 | , Data.Void.Void 136 | , Data.Void.absurd 137 | , Data.Word.Word 138 | , Data.Word.Word8 139 | , Data.Word.Word16 140 | , Data.Word.Word32 141 | , Data.Word.Word64 142 | , GHC.Enum.Bounded 143 | , GHC.Enum.Enum 144 | , GHC.Enum.fromEnum 145 | , GHC.Enum.maxBound 146 | , GHC.Enum.minBound 147 | , GHC.Err.error 148 | , GHC.Err.undefined 149 | , GHC.Exts.IsList 150 | , GHC.Exts.fromList 151 | , GHC.Float.Float 152 | , GHC.Float.Floating 153 | , GHC.Float.isInfinite 154 | , GHC.Float.isNaN 155 | , GHC.Float.logBase 156 | , GHC.Float.sqrt 157 | , (GHC.Float.**) 158 | , GHC.Float.Double 159 | , GHC.Generics.Generic 160 | , GHC.Integer.Integer 161 | , GHC.Num.Num 162 | , GHC.Num.abs 163 | , GHC.Num.fromInteger 164 | , GHC.Num.negate 165 | , (GHC.Num.+) 166 | , (GHC.Num.-) 167 | , GHC.Prim.seq 168 | , GHC.Real.Fractional 169 | , GHC.Real.Integral 170 | , GHC.Real.Real 171 | , GHC.Real.RealFrac 172 | , GHC.Real.ceiling 173 | , GHC.Real.even 174 | , GHC.Real.floor 175 | , GHC.Real.fromIntegral 176 | , GHC.Real.fromRational 177 | , GHC.Real.odd 178 | , GHC.Real.realToFrac 179 | , GHC.Real.round 180 | , GHC.Real.toInteger 181 | , GHC.Real.toRational 182 | , GHC.Real.truncate 183 | , (GHC.Real./) 184 | , (GHC.Real.^) 185 | , (GHC.Real.^^) 186 | , Numeric.Natural.Natural 187 | , System.IO.FilePath 188 | , System.IO.IO 189 | , System.IO.appendFile 190 | , System.IO.getChar 191 | , System.IO.getContents 192 | , System.IO.getLine 193 | , System.IO.interact 194 | , System.IO.print 195 | , System.IO.putChar 196 | , System.IO.putStr 197 | , System.IO.putStrLn 198 | , System.IO.readFile 199 | , System.IO.writeFile 200 | , System.IO.Error.IOError 201 | , System.IO.Error.userError 202 | , Text.Printf.printf 203 | , Text.Read.Read 204 | , Text.Show.Show 205 | , Text.Show.show 206 | , always 207 | , blank 208 | , identity 209 | , io 210 | , lookup 211 | , map 212 | , present 213 | , read 214 | , throw 215 | , toEnum 216 | , (*) 217 | , (//) 218 | , (%) 219 | , (<<<) 220 | , (<|) 221 | , (>>>) 222 | , (|>) 223 | ) 224 | where 225 | 226 | import qualified Control.Applicative 227 | import qualified Control.Category 228 | import qualified Control.Exception 229 | import qualified Control.Monad 230 | import qualified Control.Monad.Catch 231 | import qualified Control.Monad.Fail 232 | import qualified Control.Monad.IO.Class 233 | import qualified Control.Monad.Trans.Class 234 | import qualified Control.Monad.Trans.Except 235 | import qualified Control.Monad.Trans.Maybe 236 | import qualified Control.Monad.Trans.Reader 237 | import qualified Control.Monad.Trans.State 238 | import qualified Control.Monad.Trans.Writer 239 | import qualified Data.Bool 240 | import qualified Data.ByteString 241 | import qualified Data.Char 242 | import qualified Data.Data 243 | import qualified Data.Either 244 | import qualified Data.Eq 245 | import qualified Data.Fixed 246 | import qualified Data.Foldable 247 | import qualified Data.Function 248 | import qualified Data.Functor 249 | import qualified Data.Functor.Identity 250 | import qualified Data.Int 251 | import qualified Data.List 252 | import qualified Data.List.NonEmpty 253 | import qualified Data.Map 254 | import qualified Data.Maybe 255 | import qualified Data.Monoid 256 | import qualified Data.Ord 257 | import qualified Data.Ratio 258 | import qualified Data.Semigroup 259 | import qualified Data.Set 260 | import qualified Data.String 261 | import qualified Data.Text 262 | import qualified Data.Time 263 | import qualified Data.Traversable 264 | import qualified Data.Tuple 265 | import qualified Data.Typeable 266 | import qualified Data.UUID 267 | import qualified Data.Void 268 | import qualified Data.Word 269 | import qualified GHC.Enum 270 | import qualified GHC.Err 271 | import qualified GHC.Exts 272 | import qualified GHC.Float 273 | import qualified GHC.Generics 274 | import qualified GHC.Integer 275 | import qualified GHC.Num 276 | import qualified GHC.Prim 277 | import qualified GHC.Real 278 | import qualified Numeric.Natural 279 | import qualified System.IO 280 | import qualified System.IO.Error 281 | import qualified Text.Printf 282 | import qualified Text.Read 283 | import qualified Text.Show 284 | 285 | always :: a -> b -> a 286 | always = Data.Function.const 287 | 288 | blank :: Data.Foldable.Foldable t => t a -> Data.Bool.Bool 289 | blank = Data.Foldable.null 290 | 291 | identity :: a -> a 292 | identity = Data.Function.id 293 | 294 | io :: Control.Monad.IO.Class.MonadIO m => System.IO.IO a -> m a 295 | io = Control.Monad.IO.Class.liftIO 296 | 297 | lookup 298 | :: (Data.Foldable.Foldable t, Data.Eq.Eq k) 299 | => k 300 | -> t (k, v) 301 | -> Data.Maybe.Maybe v 302 | lookup k xs = Data.List.lookup k (Data.Foldable.toList xs) 303 | 304 | map :: Data.Functor.Functor f => (a -> b) -> f a -> f b 305 | map = Data.Functor.fmap 306 | 307 | present :: Data.Foldable.Foldable t => t a -> Data.Bool.Bool 308 | present xs = Data.Bool.not (blank xs) 309 | 310 | read :: Text.Read.Read a => Data.String.String -> Data.Maybe.Maybe a 311 | read = Text.Read.readMaybe 312 | 313 | throw 314 | :: (Control.Exception.Exception e, Control.Monad.Catch.MonadCatch m) 315 | => e 316 | -> m a 317 | throw = Control.Monad.Catch.throwM 318 | 319 | toEnum 320 | :: forall a 321 | . (GHC.Enum.Bounded a, GHC.Enum.Enum a) 322 | => Data.Int.Int 323 | -> Data.Maybe.Maybe a 324 | toEnum n = 325 | let 326 | tooSmall = n Data.Ord.< GHC.Enum.fromEnum @a GHC.Enum.minBound 327 | tooLarge = n Data.Ord.> GHC.Enum.fromEnum @a GHC.Enum.maxBound 328 | in if tooSmall Data.Bool.|| tooLarge 329 | then Data.Maybe.Nothing 330 | else Data.Maybe.Just (GHC.Enum.toEnum n) 331 | 332 | -- Redefined here to avoid a stylish-haskell bug. 333 | (*) :: GHC.Num.Num a => a -> a -> a 334 | (*) = (GHC.Num.*) 335 | infixl 7 * 336 | 337 | (//) :: GHC.Real.Integral a => a -> a -> a 338 | (//) = GHC.Real.div 339 | infixl 7 // 340 | 341 | (%) :: GHC.Real.Integral a => a -> a -> a 342 | (%) = GHC.Real.mod 343 | infixl 7 % 344 | 345 | (<<<) :: (b -> c) -> (a -> b) -> (a -> c) 346 | (<<<) = (Control.Category.<<<) 347 | infixr 9 <<< 348 | 349 | (<|) :: (a -> b) -> a -> b 350 | (<|) = (Data.Function.$) 351 | infixr 0 <| 352 | 353 | (>>>) :: (a -> b) -> (b -> c) -> (a -> c) 354 | (>>>) = (Control.Category.>>>) 355 | infixl 9 >>> 356 | 357 | (|>) :: a -> (a -> b) -> b 358 | (|>) = (Data.Function.&) 359 | infixl 0 |> 360 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Server/Application.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Server.Application where 2 | 3 | import qualified Monadoc.Handler.Account as Handler.Account 4 | import qualified Monadoc.Handler.Favicon as Handler.Favicon 5 | import qualified Monadoc.Handler.GitHubCallback as Handler.GitHubCallback 6 | import qualified Monadoc.Handler.Index as Handler.Index 7 | import qualified Monadoc.Handler.Logo as Handler.Logo 8 | import qualified Monadoc.Handler.LogOut as Handler.LogOut 9 | import qualified Monadoc.Handler.Ping as Handler.Ping 10 | import qualified Monadoc.Handler.Robots as Handler.Robots 11 | import qualified Monadoc.Handler.Search as Handler.Search 12 | import qualified Monadoc.Handler.Tachyons as Handler.Tachyons 13 | import qualified Monadoc.Handler.Throw as Handler.Throw 14 | import Monadoc.Prelude 15 | import qualified Monadoc.Server.Router as Router 16 | import qualified Monadoc.Type.App as App 17 | import qualified Monadoc.Type.Context as Context 18 | import qualified Monadoc.Type.NotFoundException as NotFoundException 19 | import qualified Monadoc.Type.Route as Route 20 | import qualified Monadoc.Type.WithCallStack as WithCallStack 21 | import qualified Network.Wai as Wai 22 | 23 | application :: Context.Context request -> Wai.Application 24 | application context request respond = do 25 | response <- 26 | App.run context { Context.request = request } 27 | <<< runRoute 28 | <| parseRoute request 29 | respond response 30 | 31 | parseRoute :: Wai.Request -> Maybe Route.Route 32 | parseRoute request = 33 | Router.parseRoute (Wai.requestMethod request) (Wai.pathInfo request) 34 | 35 | runRoute :: Maybe Route.Route -> App.App Wai.Request Wai.Response 36 | runRoute maybeRoute = do 37 | route <- maybe 38 | (WithCallStack.throw NotFoundException.NotFoundException) 39 | pure 40 | maybeRoute 41 | case route of 42 | Route.Account -> Handler.Account.handle 43 | Route.Favicon -> Handler.Favicon.handle 44 | Route.GitHubCallback -> Handler.GitHubCallback.handle 45 | Route.Index -> Handler.Index.handle 46 | Route.Logo -> Handler.Logo.handle 47 | Route.LogOut -> Handler.LogOut.handle 48 | Route.Ping -> Handler.Ping.handle 49 | Route.Robots -> Handler.Robots.handle 50 | Route.Search -> Handler.Search.handle 51 | Route.Tachyons -> Handler.Tachyons.handle 52 | Route.Throw -> Handler.Throw.handle 53 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Server/Common.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Server.Common where 2 | 3 | import qualified Control.Monad.Trans.Class as Trans 4 | import qualified Control.Monad.Trans.Reader as Reader 5 | import qualified Crypto.Hash as Crypto 6 | import qualified Data.ByteString as ByteString 7 | import qualified Data.ByteString.Builder as Builder 8 | import qualified Data.ByteString.Lazy as LazyByteString 9 | import qualified Data.List as List 10 | import qualified Data.Map as Map 11 | import qualified Data.Maybe as Maybe 12 | import qualified Data.Text as Text 13 | import qualified Data.UUID as Uuid 14 | import qualified Lucid as H 15 | import Monadoc.Prelude 16 | import qualified Monadoc.Server.Router as Router 17 | import qualified Monadoc.Type.App as App 18 | import qualified Monadoc.Type.Config as Config 19 | import qualified Monadoc.Type.Context as Context 20 | import qualified Monadoc.Type.Guid as Guid 21 | import qualified Monadoc.Type.Route as Route 22 | import qualified Monadoc.Type.User as User 23 | import qualified Monadoc.Utility.Utf8 as Utf8 24 | import qualified Network.HTTP.Types as Http 25 | import qualified Network.HTTP.Types.Header as Http 26 | import qualified Network.Wai as Wai 27 | import qualified Paths_monadoc as Package 28 | import qualified System.FilePath as FilePath 29 | import qualified Web.Cookie as Cookie 30 | 31 | type Headers = Map.Map Http.HeaderName ByteString.ByteString 32 | 33 | byteStringResponse 34 | :: Http.Status -> Headers -> ByteString.ByteString -> Wai.Response 35 | byteStringResponse status headers body = 36 | let 37 | contentLength = Utf8.fromString <<< show <| ByteString.length body 38 | etag = 39 | Utf8.fromString <<< show <<< show <| Crypto.hashWith Crypto.SHA256 body 40 | extraHeaders = 41 | Map.fromList [(Http.hContentLength, contentLength), (Http.hETag, etag)] 42 | in Wai.responseLBS 43 | status 44 | (Map.toList <| Map.union extraHeaders headers) 45 | (LazyByteString.fromStrict body) 46 | 47 | defaultHeaders :: Config.Config -> Headers 48 | defaultHeaders config = 49 | let 50 | contentSecurityPolicy = Utf8.fromString <| List.intercalate 51 | "; " 52 | [ "base-uri 'none'" 53 | , "default-src 'none'" 54 | , "form-action 'self'" 55 | , "frame-ancestors 'none'" 56 | , "img-src 'self'" 57 | , "style-src 'self'" 58 | ] 59 | strictTransportSecurity = 60 | let maxAge = if isSecure config then 6 * 31 * 24 * 60 * 60 else 0 :: Int 61 | in Utf8.fromString <| "max-age=" <> show maxAge 62 | in Map.fromList 63 | [ ("Content-Security-Policy", contentSecurityPolicy) 64 | , ("Feature-Policy", "notifications 'none'") 65 | , ("Referrer-Policy", "no-referrer") 66 | , ("Strict-Transport-Security", strictTransportSecurity) 67 | , ("X-Content-Type-Options", "nosniff") 68 | , ("X-Frame-Options", "deny") 69 | ] 70 | 71 | fileResponse 72 | :: Http.Status -> Headers -> FilePath -> App.App request Wai.Response 73 | fileResponse status headers name = Trans.lift <| do 74 | let relative = FilePath.combine "data" name 75 | absolute <- Package.getDataFileName relative 76 | contents <- ByteString.readFile absolute 77 | pure <| byteStringResponse status headers contents 78 | 79 | getCookieUser :: App.App Wai.Request (Maybe User.User) 80 | getCookieUser = do 81 | context <- Reader.ask 82 | case lookup Http.hCookie <<< Wai.requestHeaders <| Context.request context of 83 | Nothing -> pure Nothing 84 | Just cookie -> case lookup "guid" <| Cookie.parseCookiesText cookie of 85 | Nothing -> pure Nothing 86 | Just text -> case map Guid.fromUuid <| Uuid.fromText text of 87 | Nothing -> pure Nothing 88 | Just guid -> map Maybe.listToMaybe 89 | <| App.sql "select * from users where guid = ?" [guid] 90 | 91 | htmlResponse :: Http.Status -> Headers -> H.Html a -> Wai.Response 92 | htmlResponse status headers = 93 | byteStringResponse 94 | status 95 | (Map.insert Http.hContentType "text/html;charset=utf-8" headers) 96 | <<< LazyByteString.toStrict 97 | <<< H.renderBS 98 | 99 | isSecure :: Config.Config -> Bool 100 | isSecure = List.isPrefixOf "https:" <<< Config.url 101 | 102 | makeCookie :: Guid.Guid -> App.App request Cookie.SetCookie 103 | makeCookie guid = do 104 | config <- Reader.asks Context.config 105 | pure Cookie.defaultSetCookie 106 | { Cookie.setCookieHttpOnly = True 107 | , Cookie.setCookieName = "guid" 108 | , Cookie.setCookiePath = Just "/" 109 | , Cookie.setCookieSameSite = Just Cookie.sameSiteLax 110 | , Cookie.setCookieSecure = isSecure config 111 | , Cookie.setCookieValue = Uuid.toASCIIBytes <| Guid.toUuid guid 112 | } 113 | 114 | makeLoginUrl :: App.App Wai.Request Text.Text 115 | makeLoginUrl = do 116 | context <- Reader.ask 117 | let 118 | config = Context.config context 119 | clientId = Text.pack <| Config.clientId config 120 | route = Router.renderAbsoluteRoute config Route.GitHubCallback 121 | request = Context.request context 122 | current = Wai.rawPathInfo request <> Wai.rawQueryString request 123 | redirectUri = route 124 | <> Utf8.toText (Http.renderSimpleQuery True [("redirect", current)]) 125 | query = Http.renderQueryText 126 | True 127 | [("client_id", Just clientId), ("redirect_uri", Just redirectUri)] 128 | pure 129 | <<< Utf8.toText 130 | <<< LazyByteString.toStrict 131 | <<< Builder.toLazyByteString 132 | <| "https://github.com/login/oauth/authorize" 133 | <> query 134 | 135 | renderCookie :: Cookie.SetCookie -> ByteString.ByteString 136 | renderCookie = 137 | LazyByteString.toStrict 138 | <<< Builder.toLazyByteString 139 | <<< Cookie.renderSetCookie 140 | 141 | simpleFileResponse 142 | :: FilePath -> ByteString.ByteString -> App.App request Wai.Response 143 | simpleFileResponse file mime = do 144 | config <- Reader.asks Context.config 145 | fileResponse 146 | Http.ok200 147 | (Map.insert Http.hContentType mime <| defaultHeaders config) 148 | file 149 | 150 | statusResponse :: Http.Status -> Headers -> Wai.Response 151 | statusResponse status headers = stringResponse status headers <| unwords 152 | [show <| Http.statusCode status, Utf8.toString <| Http.statusMessage status] 153 | 154 | stringResponse :: Http.Status -> Headers -> String -> Wai.Response 155 | stringResponse status headers = 156 | byteStringResponse 157 | status 158 | (Map.insert Http.hContentType "text/plain;charset=utf-8" headers) 159 | <<< Utf8.fromString 160 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Server/Main.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Server.Main where 2 | 3 | import qualified Control.Monad.Trans.Class as Trans 4 | import qualified Control.Monad.Trans.Reader as Reader 5 | import Monadoc.Prelude 6 | import qualified Monadoc.Server.Application as Application 7 | import qualified Monadoc.Server.Middleware as Middleware 8 | import qualified Monadoc.Server.Settings as Settings 9 | import qualified Monadoc.Type.App as App 10 | import qualified Monadoc.Utility.Console as Console 11 | import qualified Network.Wai.Handler.Warp as Warp 12 | 13 | run :: App.App request () 14 | run = do 15 | Console.info "Starting server ..." 16 | context <- Reader.ask 17 | Trans.lift 18 | <<< Warp.runSettings (Settings.fromContext context) 19 | <<< Middleware.middleware context 20 | <| Application.application context 21 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Server/Middleware.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Server.Middleware where 2 | 3 | import qualified Codec.Compression.GZip as Gzip 4 | import qualified Control.Monad.Catch as Exception 5 | import qualified Crypto.Hash as Crypto 6 | import qualified Data.ByteString.Builder as Builder 7 | import qualified Data.ByteString.Lazy as LazyByteString 8 | import qualified Data.Maybe as Maybe 9 | import qualified Data.Text as Text 10 | import qualified GHC.Clock as Clock 11 | import Monadoc.Prelude 12 | import qualified Monadoc.Server.Settings as Settings 13 | import qualified Monadoc.Type.Context as Context 14 | import qualified Monadoc.Utility.Console as Console 15 | import qualified Monadoc.Utility.Utf8 as Utf8 16 | import qualified Network.HTTP.Types as Http 17 | import qualified Network.HTTP.Types.Header as Http 18 | import qualified Network.Wai as Wai 19 | import qualified Network.Wai.Internal as Wai 20 | import qualified System.Mem as Mem 21 | import qualified Text.Printf as Printf 22 | 23 | middleware :: Context.Context request -> Wai.Middleware 24 | middleware context = 25 | logRequests <<< handleExceptions context <<< handleEtag <<< compress 26 | 27 | logRequests :: Wai.Middleware 28 | logRequests process request respond = do 29 | timeBefore <- Clock.getMonotonicTime 30 | allocationsBefore <- Mem.getAllocationCounter 31 | process request <| \response -> do 32 | allocationsAfter <- Mem.getAllocationCounter 33 | timeAfter <- Clock.getMonotonicTime 34 | Console.info <| Printf.printf 35 | "%d %s %s%s %.3f %d" 36 | (Http.statusCode <| Wai.responseStatus response) 37 | (Utf8.toString <| Wai.requestMethod request) 38 | (Utf8.toString <| Wai.rawPathInfo request) 39 | (Utf8.toString <| Wai.rawQueryString request) 40 | (timeAfter - timeBefore) 41 | ((allocationsBefore - allocationsAfter) // 1024) 42 | respond response 43 | 44 | handleExceptions :: Context.Context request -> Wai.Middleware 45 | handleExceptions context process request respond = 46 | Exception.catch (process request respond) <| \someException -> do 47 | Settings.onException context (Just request) someException 48 | respond 49 | <| Settings.onExceptionResponse (Context.config context) someException 50 | 51 | handleEtag :: Wai.Middleware 52 | handleEtag process request respond = process request <| \response -> 53 | let 54 | isGet = Wai.requestMethod request == Http.methodGet 55 | isSuccessful = Http.statusIsSuccessful <| Wai.responseStatus response 56 | expected = lookup Http.hIfNoneMatch <| Wai.requestHeaders request 57 | hasEtag = Maybe.isJust expected 58 | actual = lookup Http.hETag <| Wai.responseHeaders response 59 | in respond <| if isGet && isSuccessful && hasEtag && actual == expected 60 | then Wai.responseLBS 61 | Http.notModified304 62 | (filter (\header -> not <| isContentLength header || isETag header) 63 | <| Wai.responseHeaders response 64 | ) 65 | LazyByteString.empty 66 | else response 67 | 68 | isContentLength :: Http.Header -> Bool 69 | isContentLength = (== Http.hContentLength) <<< fst 70 | 71 | isETag :: Http.Header -> Bool 72 | isETag = (== Http.hETag) <<< fst 73 | 74 | compress :: Wai.Middleware 75 | compress process request respond = process request <| \response -> 76 | respond <| case response of 77 | Wai.ResponseBuilder status headers builder -> 78 | let 79 | expanded = Builder.toLazyByteString builder 80 | compressed = Gzip.compress expanded 81 | size = Utf8.fromString <<< show <| LazyByteString.length compressed 82 | etag = 83 | Utf8.fromString 84 | <<< show 85 | <<< show 86 | <<< Crypto.hashWith Crypto.SHA256 87 | <| LazyByteString.toStrict compressed 88 | newHeaders = 89 | (Http.hContentEncoding, "gzip") 90 | : (Http.hContentLength, size) 91 | : (Http.hETag, etag) 92 | : filter 93 | (\header -> not <| isContentLength header || isETag header) 94 | headers 95 | in if acceptsGzip request 96 | && not (isEncoded response) 97 | && longEnough expanded 98 | then 99 | Wai.responseLBS status newHeaders compressed 100 | else 101 | response 102 | _ -> response 103 | 104 | isEncoded :: Wai.Response -> Bool 105 | isEncoded = 106 | Maybe.isJust <<< lookup Http.hContentEncoding <<< Wai.responseHeaders 107 | 108 | acceptsGzip :: Wai.Request -> Bool 109 | acceptsGzip = 110 | elem "gzip" 111 | <<< map Text.strip 112 | <<< Text.splitOn "," 113 | <<< Utf8.toText 114 | <<< Maybe.fromMaybe "" 115 | <<< lookup Http.hAcceptEncoding 116 | <<< Wai.requestHeaders 117 | 118 | longEnough :: LazyByteString.ByteString -> Bool 119 | longEnough = (> 1024) <<< LazyByteString.length 120 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Server/Router.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Server.Router where 2 | 3 | import qualified Data.Text as Text 4 | import Monadoc.Prelude 5 | import qualified Monadoc.Type.Config as Config 6 | import qualified Monadoc.Type.Route as Route 7 | import qualified Network.HTTP.Types as Http 8 | 9 | parseRoute :: Http.Method -> [Text.Text] -> Maybe Route.Route 10 | parseRoute method path = do 11 | stdMethod <- either (always Nothing) Just <| Http.parseMethod method 12 | case (stdMethod, path) of 13 | (Http.GET, []) -> Just Route.Index 14 | (Http.GET, ["account"]) -> Just Route.Account 15 | (Http.GET, ["api", "github-callback"]) -> Just Route.GitHubCallback 16 | (Http.POST, ["api", "log-out"]) -> Just Route.LogOut 17 | (Http.GET, ["api", "ping"]) -> Just Route.Ping 18 | (Http.GET, ["api", "throw"]) -> Just Route.Throw 19 | (Http.GET, ["favicon.ico"]) -> Just Route.Favicon 20 | (Http.GET, ["robots.txt"]) -> Just Route.Robots 21 | (Http.GET, ["search"]) -> Just Route.Search 22 | (Http.GET, ["static", "logo.png"]) -> Just Route.Logo 23 | (Http.GET, ["static", "tachyons-4-12-0.css"]) -> Just Route.Tachyons 24 | _ -> Nothing 25 | 26 | renderRelativeRoute :: Route.Route -> Text.Text 27 | renderRelativeRoute route = case route of 28 | Route.Account -> "/account" 29 | Route.Favicon -> "/favicon.ico" 30 | Route.GitHubCallback -> "/api/github-callback" 31 | Route.Index -> "/" 32 | Route.Logo -> "/static/logo.png" 33 | Route.LogOut -> "/api/log-out" 34 | Route.Ping -> "/api/ping" 35 | Route.Robots -> "/robots.txt" 36 | Route.Search -> "/search" 37 | Route.Tachyons -> "/static/tachyons-4-12-0.css" 38 | Route.Throw -> "/api/throw" 39 | 40 | renderAbsoluteRoute :: Config.Config -> Route.Route -> Text.Text 41 | renderAbsoluteRoute config = 42 | (Text.pack (Config.url config) <>) <<< renderRelativeRoute 43 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Server/Settings.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Server.Settings where 2 | 3 | import qualified Control.Monad as Monad 4 | import qualified Control.Monad.Catch as Exception 5 | import qualified Data.ByteString as ByteString 6 | import qualified Data.Proxy as Proxy 7 | import qualified Monadoc.Data.Commit as Commit 8 | import qualified Monadoc.Data.Version as Version 9 | import Monadoc.Prelude 10 | import qualified Monadoc.Server.Common as Common 11 | import qualified Monadoc.Type.Config as Config 12 | import qualified Monadoc.Type.Context as Context 13 | import qualified Monadoc.Type.NotFoundException as NotFoundException 14 | import qualified Monadoc.Type.TestException as TestException 15 | import qualified Monadoc.Type.WithCallStack as WithCallStack 16 | import qualified Monadoc.Utility.Console as Console 17 | import qualified Monadoc.Utility.Utf8 as Utf8 18 | import qualified Network.HTTP.Client as Client 19 | import qualified Network.HTTP.Types as Http 20 | import qualified Network.Wai as Wai 21 | import qualified Network.Wai.Handler.Warp as Warp 22 | 23 | -- | Builds Warp server settings from a context. 24 | fromContext :: Context.Context request -> Warp.Settings 25 | fromContext context = 26 | let config = Context.config context 27 | in 28 | Warp.setBeforeMainLoop (beforeMainLoop config) 29 | <<< Warp.setHost (Config.host config) 30 | <<< Warp.setOnException (onException context) 31 | <<< Warp.setOnExceptionResponse (onExceptionResponse config) 32 | <<< Warp.setPort (Config.port config) 33 | <| Warp.setServerName serverName Warp.defaultSettings 34 | 35 | beforeMainLoop :: Config.Config -> IO () 36 | beforeMainLoop config = Console.info <| unwords 37 | [ "Listening on" 38 | , show <| Config.host config 39 | , "port" 40 | , show <| Config.port config 41 | , "..." 42 | ] 43 | 44 | onException 45 | :: Context.Context request 46 | -> Maybe Wai.Request 47 | -> Exception.SomeException 48 | -> IO () 49 | onException context _ exception 50 | | not <| Warp.defaultShouldDisplayException exception = pure () 51 | | isType notFoundException exception = pure () 52 | | isType testException exception = pure () 53 | | otherwise = do 54 | Console.warn <| Exception.displayException exception 55 | sendExceptionToDiscord context exception 56 | 57 | sendExceptionToDiscord 58 | :: Context.Context request -> Exception.SomeException -> IO () 59 | sendExceptionToDiscord context exception = 60 | case Client.parseRequest <<< Config.discordUrl <| Context.config context of 61 | Left someException -> case Exception.fromException someException of 62 | Just (Client.InvalidUrlException url reason) -> 63 | Console.warn <| "invalid Discord URL (" <> reason <> "): " <> show url 64 | _ -> Exception.throwM someException 65 | Right initialRequest -> do 66 | let 67 | content = Utf8.fromString 68 | <| fold ["```\n", Exception.displayException exception, "```"] 69 | request = Client.urlEncodedBody [("content", content)] initialRequest 70 | manager = Context.manager context 71 | Monad.void <| Client.httpLbs request manager 72 | 73 | onExceptionResponse :: Config.Config -> Exception.SomeException -> Wai.Response 74 | onExceptionResponse config exception 75 | | isType notFoundException exception = Common.statusResponse 76 | Http.notFound404 77 | headers 78 | | otherwise = Common.statusResponse Http.internalServerError500 headers 79 | where headers = Common.defaultHeaders config 80 | 81 | notFoundException :: Proxy.Proxy NotFoundException.NotFoundException 82 | notFoundException = Proxy.Proxy 83 | 84 | testException :: Proxy.Proxy TestException.TestException 85 | testException = Proxy.Proxy 86 | 87 | isType 88 | :: Exception.Exception e => Proxy.Proxy e -> Exception.SomeException -> Bool 89 | isType proxy = 90 | maybe False (always True <<< asType proxy) 91 | <<< Exception.fromException 92 | <<< WithCallStack.withoutCallStack 93 | 94 | asType :: Proxy.Proxy a -> a -> a 95 | asType _ = identity 96 | 97 | serverName :: ByteString.ByteString 98 | serverName = 99 | Utf8.fromString <| "monadoc-" <> Version.string <> case Commit.hash of 100 | Nothing -> "" 101 | Just hash -> "-" <> hash 102 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Server/Template.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Server.Template where 2 | 3 | import qualified Data.Text as Text 4 | import qualified Lucid as H 5 | import qualified Monadoc.Data.Commit as Commit 6 | import qualified Monadoc.Data.Version as Version 7 | import Monadoc.Prelude 8 | import qualified Monadoc.Server.Router as Router 9 | import qualified Monadoc.Type.Config as Config 10 | import qualified Monadoc.Type.GitHub.Login as Login 11 | import qualified Monadoc.Type.Route as Route 12 | import qualified Monadoc.Type.User as User 13 | 14 | makeHtmlWith 15 | :: Config.Config -> Maybe User.User -> Text.Text -> H.Html () -> H.Html () 16 | makeHtmlWith config maybeUser loginUrl content = do 17 | let route = Router.renderAbsoluteRoute config 18 | H.doctype_ 19 | H.html_ [H.class_ "bg-near-white black sans-serif", H.lang_ "en-US"] <| do 20 | H.head_ <| do 21 | H.meta_ [H.charset_ "utf-8"] 22 | H.meta_ 23 | [ H.name_ "description" 24 | , H.content_ "\x1f516 Better Haskell documentation." 25 | ] 26 | H.meta_ 27 | [H.name_ "viewport", H.content_ "initial-scale=1,width=device-width"] 28 | let og k v = H.meta_ [H.term "property" <| "og:" <> k, H.content_ v] 29 | og "title" "Monadoc" 30 | og "type" "website" 31 | let url = route Route.Index 32 | og "url" url 33 | og "image" <| route Route.Logo 34 | H.link_ [H.rel_ "canonical", H.href_ url] 35 | H.link_ [H.rel_ "icon", H.href_ <| route Route.Favicon] 36 | H.link_ [H.rel_ "apple-touch-icon", H.href_ <| route Route.Logo] 37 | H.link_ [H.rel_ "stylesheet", H.href_ <| route Route.Tachyons] 38 | H.title_ "Monadoc" 39 | H.body_ <| do 40 | H.header_ [H.class_ "bg-purple white"] 41 | <<< H.div_ [H.class_ "center mw8 pa3"] 42 | <| do 43 | H.div_ [H.class_ "flex items-center justify-between"] <| do 44 | H.h1_ [H.class_ "f2 lh-solid ma0 tracked-tight"] <| H.a_ 45 | [ H.class_ "color-inherit no-underline" 46 | , H.href_ <| route Route.Index 47 | ] 48 | "Monadoc" 49 | case maybeUser of 50 | Nothing -> H.a_ 51 | [H.class_ "color-inherit no-underline", H.href_ loginUrl] 52 | "Log in with GitHub" 53 | Just user -> 54 | H.a_ 55 | [ H.class_ "color-inherit no-underline" 56 | , H.href_ <| route Route.Account 57 | ] 58 | <<< H.toHtml 59 | <<< Text.cons '@' 60 | <<< Login.toText 61 | <| User.login user 62 | H.div_ [H.class_ "center mw8 pa3"] 63 | <<< H.form_ 64 | [ H.action_ <| route Route.Search 65 | , H.class_ "b--inherit ba bg-white flex items-center" 66 | ] 67 | <| do 68 | H.input_ 69 | [ H.class_ "bn pa2 w-100" 70 | , H.name_ "query" 71 | , H.placeholder_ "Search for something ..." 72 | ] 73 | H.input_ 74 | [ H.class_ "b bg-inherit bn pa2 pointer" 75 | , H.type_ "submit" 76 | , H.value_ "Search" 77 | ] 78 | H.main_ [H.class_ "bg-white"] 79 | <| H.div_ [H.class_ "center mw8 pa3"] content 80 | H.footer_ [H.class_ "center mid-gray mw8 pa3 tc"] <| do 81 | "Powered by " 82 | H.a_ 83 | [ H.class_ "color-inherit" 84 | , H.href_ "https://github.com/tfausak/monadoc" 85 | ] 86 | "Monadoc" 87 | " version " 88 | H.code_ <| H.toHtml Version.string 89 | case Commit.hash of 90 | Nothing -> pure () 91 | Just commit -> do 92 | " commit " 93 | H.code_ <<< H.toHtml <| take 7 commit 94 | "." 95 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/App.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.App where 2 | 3 | import qualified Control.Monad as Monad 4 | import qualified Control.Monad.Trans.Class as Trans 5 | import qualified Control.Monad.Trans.Reader as Reader 6 | import qualified Data.Pool as Pool 7 | import qualified Database.SQLite.Simple as Sql 8 | import Monadoc.Prelude 9 | import qualified Monadoc.Type.Context as Context 10 | 11 | -- | The main application type. This simply provides the run-time context. Use 12 | -- 'run' to convert this into 'IO'. 13 | type App request result = Reader.ReaderT (Context.Context request) IO result 14 | 15 | -- | Runs an 'App' action. 16 | run :: Context.Context request -> App request result -> IO result 17 | run = flip Reader.runReaderT 18 | 19 | -- | Runs a SQL query and returns the results. 20 | sql :: (Sql.FromRow b, Sql.ToRow a) => Sql.Query -> a -> App request [b] 21 | sql query params = withConnection 22 | <| \connection -> Trans.lift <| Sql.query connection query params 23 | 24 | -- | Runs a SQL query and discards the results. 25 | sql_ :: Sql.ToRow a => Sql.Query -> a -> App request () 26 | sql_ query params = 27 | Monad.void (sql query params :: App request [[Sql.SQLData]]) 28 | 29 | -- | Checks out a SQL connection from the pool and runs the given action with 30 | -- it. 31 | withConnection :: (Sql.Connection -> App request result) -> App request result 32 | withConnection action = do 33 | pool <- Reader.asks Context.pool 34 | Pool.withResource pool action 35 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/Binary.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Binary where 2 | 3 | import qualified Data.ByteString as ByteString 4 | import qualified Database.SQLite.Simple.FromField as Sql 5 | import qualified Database.SQLite.Simple.ToField as Sql 6 | import Monadoc.Prelude 7 | 8 | -- | Some binary data. Just a 'ByteString.ByteString' under the hood. Use 9 | -- 'fromByteString' and 'toByteString' to work with these values. 10 | newtype Binary 11 | = Binary ByteString.ByteString 12 | deriving (Eq, Show) 13 | 14 | instance Sql.FromField Binary where 15 | fromField = map fromByteString <<< Sql.fromField 16 | 17 | instance Sql.ToField Binary where 18 | toField = Sql.toField <<< toByteString 19 | 20 | fromByteString :: ByteString.ByteString -> Binary 21 | fromByteString = Binary 22 | 23 | toByteString :: Binary -> ByteString.ByteString 24 | toByteString (Binary byteString) = byteString 25 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/Cabal/ModuleName.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Cabal.ModuleName where 2 | 3 | import qualified Data.List as List 4 | import qualified Database.SQLite.Simple.ToField as Sql 5 | import qualified Distribution.ModuleName as Cabal 6 | import Monadoc.Prelude 7 | 8 | newtype ModuleName = ModuleName Cabal.ModuleName deriving (Eq, Ord, Show) 9 | 10 | instance Sql.ToField ModuleName where 11 | toField = Sql.toField <<< toString 12 | 13 | fromCabal :: Cabal.ModuleName -> ModuleName 14 | fromCabal = ModuleName 15 | 16 | fromString :: String -> ModuleName 17 | fromString = fromCabal <<< Cabal.fromString 18 | 19 | fromStrings :: [String] -> ModuleName 20 | fromStrings = fromCabal <<< Cabal.fromComponents 21 | 22 | toCabal :: ModuleName -> Cabal.ModuleName 23 | toCabal (ModuleName cabal) = cabal 24 | 25 | toString :: ModuleName -> String 26 | toString = List.intercalate "." <<< toStrings 27 | 28 | toStrings :: ModuleName -> [String] 29 | toStrings = Cabal.components <<< toCabal 30 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/Cabal/PackageName.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Cabal.PackageName where 2 | 3 | import qualified Database.SQLite.Simple.ToField as Sql 4 | import qualified Distribution.Parsec as Cabal 5 | import qualified Distribution.Pretty as Cabal 6 | import qualified Distribution.Types.PackageName as Cabal 7 | import Monadoc.Prelude 8 | 9 | newtype PackageName 10 | = PackageName Cabal.PackageName 11 | deriving (Eq, Ord, Show) 12 | 13 | instance Sql.ToField PackageName where 14 | toField = Sql.toField <<< toString 15 | 16 | fromCabal :: Cabal.PackageName -> PackageName 17 | fromCabal = PackageName 18 | 19 | fromString :: String -> Maybe PackageName 20 | fromString = map fromCabal <<< Cabal.simpleParsec 21 | 22 | toCabal :: PackageName -> Cabal.PackageName 23 | toCabal (PackageName cabal) = cabal 24 | 25 | toString :: PackageName -> String 26 | toString = Cabal.prettyShow <<< toCabal 27 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/Cabal/Version.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Cabal.Version where 2 | 3 | import qualified Data.List as List 4 | import qualified Database.SQLite.Simple.ToField as Sql 5 | import qualified Distribution.Parsec as Cabal 6 | import qualified Distribution.Types.Version as Cabal 7 | import Monadoc.Prelude 8 | 9 | newtype Version = Version Cabal.Version deriving (Eq, Ord, Show) 10 | 11 | instance Sql.ToField Version where 12 | toField = Sql.toField <<< toString 13 | 14 | fromCabal :: Cabal.Version -> Version 15 | fromCabal = Version 16 | 17 | fromString :: String -> Maybe Version 18 | fromString = map fromCabal <<< Cabal.simpleParsec 19 | 20 | toCabal :: Version -> Cabal.Version 21 | toCabal (Version cabal) = cabal 22 | 23 | toString :: Version -> String 24 | toString = 25 | List.intercalate "." <<< map show <<< Cabal.versionNumbers <<< toCabal 26 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/Cabal/VersionRange.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Cabal.VersionRange where 2 | 3 | import qualified Database.SQLite.Simple.ToField as Sql 4 | import qualified Distribution.Parsec as Cabal 5 | import qualified Distribution.Pretty as Cabal 6 | import qualified Distribution.Types.VersionRange as Cabal 7 | import Monadoc.Prelude 8 | 9 | newtype VersionRange 10 | = VersionRange Cabal.VersionRange 11 | deriving (Eq, Show) 12 | 13 | instance Sql.ToField VersionRange where 14 | toField = Sql.toField <<< toString 15 | 16 | fromCabal :: Cabal.VersionRange -> VersionRange 17 | fromCabal = VersionRange 18 | 19 | fromString :: String -> Maybe VersionRange 20 | fromString = map fromCabal <<< Cabal.simpleParsec 21 | 22 | toCabal :: VersionRange -> Cabal.VersionRange 23 | toCabal (VersionRange cabal) = cabal 24 | 25 | toString :: VersionRange -> String 26 | toString = Cabal.prettyShow <<< toCabal 27 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/Config.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Config where 2 | 3 | import qualified Data.Set as Set 4 | import Monadoc.Prelude 5 | import qualified Monadoc.Type.Service as Service 6 | import qualified Network.Wai.Handler.Warp as Warp 7 | 8 | -- | Application configuration. This contains all the stuff necessary to start 9 | -- things up. Descriptions and defaults are available by running the executable 10 | -- with @--help@. 11 | -- 12 | -- It is expected that each field here will have a corresponding option defined 13 | -- in "Monadoc.Data.Options". 14 | data Config = Config 15 | { clientId :: String 16 | -- ^ The client ID for the GitHub OAuth application. Make sure this goes with 17 | -- the secret. The default will work for local development, but you'll need 18 | -- to make your own app to get this working in any other environments. 19 | , clientSecret :: String 20 | -- ^ The client secret for the GitHub OAuth application. Make sure this goes 21 | -- with the ID. 22 | , database :: FilePath 23 | -- ^ The path to the database file. To use an in-memory databse, set this to 24 | -- either the empty string or @":memory:"@. 25 | , discordUrl :: String 26 | -- ^ A URL to execute a Discord webhook. This is currently used for easy 27 | -- exception reporting. If you don't have a Discord server set up, set this 28 | -- to the empty string. 29 | , hackageUrl :: String 30 | -- ^ The base Hackage URL. This can be useful to point to a mirror or even a 31 | -- local Hackage server. 32 | , help :: Bool 33 | -- ^ Whether or not the help should be shown. 34 | , host :: Warp.HostPreference 35 | -- ^ The host to bind on. In typical usage you'll want to set this to @"*"@. 36 | , port :: Warp.Port 37 | -- ^ The port to bind on. 38 | , services :: Set.Set Service.Service 39 | , url :: String 40 | -- ^ The base URL that the site is available at. Be sure to change this if 41 | -- you change the port. 42 | , version :: Bool 43 | -- ^ Whether or not to show the version number. 44 | } deriving (Eq, Show) 45 | 46 | -- | The default config. These values are optimized for development. 47 | initial :: Config 48 | initial = Config 49 | { clientId = "235ce8c873f4ed90905c" 50 | , clientSecret = "48e202a2b3aa30ad2a4e844f77b7d10807ab1deb" 51 | , database = "monadoc.sqlite3" 52 | , discordUrl = "" 53 | , hackageUrl = "https://hackage.haskell.org" 54 | , help = False 55 | , host = "127.0.0.1" 56 | , port = 4444 57 | , services = Set.fromList [Service.Server, Service.Worker] 58 | , url = "http://localhost:4444" 59 | , version = False 60 | } 61 | 62 | -- | A config optimized for testing. 63 | test :: Config 64 | test = initial 65 | { database = ":memory:" 66 | , hackageUrl = "http://hackage.test" 67 | , url = "http://monadoc.test:4444" 68 | } 69 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/ConfigResult.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.ConfigResult where 2 | 3 | import qualified Data.List.NonEmpty as NonEmpty 4 | import Monadoc.Prelude 5 | import qualified Monadoc.Type.Config as Config 6 | 7 | -- | The result of attempting to get the config from the environment. 8 | data ConfigResult 9 | = Failure (NonEmpty.NonEmpty String) 10 | -- ^ Getting the config failed with one or more errors. Each error will start 11 | -- with @"ERROR: "@ and end with a newline. 12 | | ExitWith String 13 | -- ^ Getting the config succeeded, but the program should exit early with the 14 | -- given message. This is used when showing the help or version number. The 15 | -- message will end with a newline. 16 | | Success [String] Config.Config 17 | -- ^ Getting the config succeeded in spite of some warnings. Each warning 18 | -- will start with @"WARNING: "@ and end with a newline. 19 | deriving (Eq, Show) 20 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/Context.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Context where 2 | 3 | import qualified Data.Pool as Pool 4 | import qualified Database.SQLite.Simple as Sql 5 | import qualified Monadoc.Type.Config as Config 6 | import qualified Network.HTTP.Client as Client 7 | 8 | import Prelude () 9 | -- import Monadoc.Prelude 10 | 11 | -- | The run-time application context. This will be available in most places 12 | -- and is basically a grab bag of global state. 13 | data Context request = Context 14 | { config :: Config.Config 15 | -- ^ The config used to create this context, just in case we still need some 16 | -- values from it. 17 | , manager :: Client.Manager 18 | -- ^ A manager for making HTTP requests. 19 | , pool :: Pool.Pool Sql.Connection 20 | -- ^ A pool of SQLite connections for talking to the database. 21 | , request :: request 22 | -- ^ An optional request. Since the app runs as both a server and a worker, 23 | -- the presence of a request is communicated through the types rather than 24 | -- using something like @Maybe Request@. 25 | } 26 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/Etag.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Etag where 2 | 3 | import qualified Data.ByteString as ByteString 4 | import qualified Database.SQLite.Simple.FromField as Sql 5 | import qualified Database.SQLite.Simple.ToField as Sql 6 | import Monadoc.Prelude 7 | import qualified Monadoc.Utility.Sql as Sql 8 | import qualified Text.Read as Read 9 | 10 | -- | An HTTP entity tag (ETag). Values typically come from HTTP headers, so 11 | -- this is a 'ByteString.ByteString' behind the scenes. Usually values are 12 | -- quoted ASCII strings like @"01ef"@. Use 'fromByteString' and 'toByteString' 13 | -- for conversion. 14 | newtype Etag 15 | = Etag ByteString.ByteString 16 | deriving (Eq, Show) 17 | 18 | instance Sql.FromField Etag where 19 | fromField = Sql.fromFieldVia <| map fromByteString <<< Read.readMaybe 20 | 21 | instance Sql.ToField Etag where 22 | toField = Sql.toField <<< show <<< toByteString 23 | 24 | fromByteString :: ByteString.ByteString -> Etag 25 | fromByteString = Etag 26 | 27 | toByteString :: Etag -> ByteString.ByteString 28 | toByteString (Etag byteString) = byteString 29 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/GitHub/Login.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.GitHub.Login where 2 | 3 | import qualified Data.Aeson as Aeson 4 | import qualified Data.Text as Text 5 | import qualified Database.SQLite.Simple.FromField as Sql 6 | import qualified Database.SQLite.Simple.ToField as Sql 7 | import Monadoc.Prelude 8 | 9 | -- | A GitHub user's login, which is more commonly known as their username. 10 | -- This is the part that comes after \@, like \@tfausak. 11 | newtype Login 12 | = Login Text.Text 13 | deriving (Eq, Show) 14 | 15 | instance Sql.FromField Login where 16 | fromField = map fromText <<< Sql.fromField 17 | 18 | instance Aeson.FromJSON Login where 19 | parseJSON = map fromText <<< Aeson.parseJSON 20 | 21 | instance Sql.ToField Login where 22 | toField = Sql.toField <<< toText 23 | 24 | fromText :: Text.Text -> Login 25 | fromText = Login 26 | 27 | toText :: Login -> Text.Text 28 | toText (Login text) = text 29 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/GitHub/User.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.GitHub.User where 2 | 3 | import qualified Data.Aeson as Aeson 4 | import Monadoc.Prelude 5 | import qualified Monadoc.Type.GitHub.Login as Login 6 | import qualified Monadoc.Type.GitHub.UserId as UserId 7 | 8 | -- | A GitHub user, as described by their v3 REST API. We only care about a 9 | -- subset of the fields. For a list of all the fields, see 10 | -- . 11 | data User = User 12 | { id :: UserId.UserId 13 | , login :: Login.Login 14 | } deriving (Eq, Show) 15 | 16 | instance Aeson.FromJSON User where 17 | parseJSON = Aeson.withObject "User" <| \object -> do 18 | id_ <- object Aeson..: "id" 19 | login_ <- object Aeson..: "login" 20 | pure User { id = id_, login = login_ } 21 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/GitHub/UserId.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.GitHub.UserId where 2 | 3 | import qualified Data.Aeson as Aeson 4 | import qualified Database.SQLite.Simple.FromField as Sql 5 | import qualified Database.SQLite.Simple.ToField as Sql 6 | import Monadoc.Prelude 7 | 8 | -- | A GitHub user's integral ID. This isn't normally surfaced through their 9 | -- UI, but it's a stable identifier. Note that people can change their 10 | -- usernames, which are called "logins" in GitHub parlance. 11 | newtype UserId 12 | = UserId Int 13 | deriving (Eq, Show) 14 | 15 | instance Sql.FromField UserId where 16 | fromField = map fromInt <<< Sql.fromField 17 | 18 | instance Aeson.FromJSON UserId where 19 | parseJSON = map fromInt <<< Aeson.parseJSON 20 | 21 | instance Sql.ToField UserId where 22 | toField = Sql.toField <<< toInt 23 | 24 | fromInt :: Int -> UserId 25 | fromInt = UserId 26 | 27 | toInt :: UserId -> Int 28 | toInt (UserId int) = int 29 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/Guid.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Guid where 2 | 3 | import qualified Data.Bifunctor as Bifunctor 4 | import qualified Data.UUID as Uuid 5 | import qualified Database.SQLite.Simple.FromField as Sql 6 | import qualified Database.SQLite.Simple.ToField as Sql 7 | import Monadoc.Prelude 8 | import qualified Monadoc.Utility.Sql as Sql 9 | import qualified System.Random as Random 10 | 11 | -- | A thin wrapper around a UUID. This is called "GUID" because it's easier to 12 | -- say as a word. It rhymes with "squid". 13 | newtype Guid 14 | = Guid Uuid.UUID 15 | deriving (Eq, Show) 16 | 17 | instance Sql.FromField Guid where 18 | fromField = Sql.fromFieldVia <| map fromUuid <<< Uuid.fromText 19 | 20 | instance Random.Random Guid where 21 | random = Bifunctor.first fromUuid <<< Random.random 22 | randomR r = Bifunctor.first fromUuid <<< Random.randomR (both toUuid r) 23 | 24 | instance Sql.ToField Guid where 25 | toField = Sql.toField <<< Uuid.toText <<< toUuid 26 | 27 | both :: Bifunctor.Bifunctor p => (a -> b) -> p a a -> p b b 28 | both f = Bifunctor.bimap f f 29 | 30 | fromUuid :: Uuid.UUID -> Guid 31 | fromUuid = Guid 32 | 33 | random :: Random.RandomGen g => g -> (Guid, g) 34 | random = Random.random 35 | 36 | toUuid :: Guid -> Uuid.UUID 37 | toUuid (Guid uuid) = uuid 38 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/Migration.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Migration where 2 | 3 | import qualified Crypto.Hash as Crypto 4 | import qualified Data.Ord as Ord 5 | import qualified Database.SQLite.Simple as Sql 6 | import qualified Database.SQLite.Simple.ToField as Sql 7 | import Monadoc.Prelude 8 | import qualified Monadoc.Type.Sha256 as Sha256 9 | import qualified Monadoc.Type.Timestamp as Timestamp 10 | import qualified Monadoc.Utility.Utf8 as Utf8 11 | 12 | -- | A database migration. This is a single SQL statement along with a 13 | -- timestamp. The timestamp is used both to order the migrations and as a 14 | -- unique key for identifying them. 15 | data Migration = Migration 16 | { query :: Sql.Query 17 | , timestamp :: Timestamp.Timestamp 18 | } deriving (Eq, Show) 19 | 20 | instance Ord Migration where 21 | compare x y = Ord.comparing timestamp x y <> Ord.comparing query x y 22 | 23 | instance Sql.ToRow Migration where 24 | toRow migration = 25 | [Sql.toField <| timestamp migration, Sql.toField <| sha256 migration] 26 | 27 | -- | Computes a digest of the 'Migration' 'query'. This is used to make sure 28 | -- that the migration hasn't changed since it was ran. 29 | sha256 :: Migration -> Sha256.Sha256 30 | sha256 = 31 | Sha256.fromDigest 32 | <<< Crypto.hash 33 | <<< Utf8.fromText 34 | <<< Sql.fromQuery 35 | <<< query 36 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/MigrationMismatch.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.MigrationMismatch where 2 | 3 | import qualified Control.Monad.Catch as Exception 4 | import Monadoc.Prelude 5 | import qualified Monadoc.Type.Sha256 as Sha256 6 | import qualified Monadoc.Type.Timestamp as Timestamp 7 | 8 | -- | A content mismatch when running a migration. This is thrown when the 9 | -- digest of a migration has changed since it was ran. Identifying these cases 10 | -- is useful to ensure data consistency. 11 | data MigrationMismatch = MigrationMismatch 12 | { actual :: Sha256.Sha256 13 | , expected :: Sha256.Sha256 14 | , timestamp :: Timestamp.Timestamp 15 | } deriving (Eq, Show) 16 | 17 | instance Exception.Exception MigrationMismatch where 18 | displayException migrationMismatch = unwords 19 | [ "migration" 20 | , show <<< Timestamp.toUtcTime <| timestamp migrationMismatch 21 | , "expected" 22 | , show <<< Sha256.toDigest <| expected migrationMismatch 23 | , "but got" 24 | , show <<< Sha256.toDigest <| actual migrationMismatch 25 | ] 26 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/NotFoundException.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.NotFoundException where 2 | 3 | import qualified Control.Monad.Catch as Exception 4 | import Monadoc.Prelude 5 | 6 | data NotFoundException 7 | = NotFoundException 8 | deriving (Eq, Show) 9 | 10 | instance Exception.Exception NotFoundException 11 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/Path.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Path where 2 | 3 | import qualified Database.SQLite.Simple.FromField as Sql 4 | import qualified Database.SQLite.Simple.ToField as Sql 5 | import Monadoc.Prelude 6 | import qualified System.FilePath.Posix as Posix 7 | import qualified System.FilePath.Windows as Windows 8 | 9 | -- | A relative file path. Typically these come from tar entries. We store each 10 | -- path segment separately to avoid directory separator problems between Linux 11 | -- and Windows. 12 | newtype Path 13 | = Path [String] 14 | deriving (Eq, Show) 15 | 16 | instance Monoid Path where 17 | mempty = fromStrings mempty 18 | 19 | instance Sql.FromField Path where 20 | fromField = map fromFilePath <<< Sql.fromField 21 | 22 | instance Semigroup Path where 23 | x <> y = fromStrings <| toStrings x <> toStrings y 24 | 25 | instance Sql.ToField Path where 26 | toField = Sql.toField <<< toFilePath 27 | 28 | -- | Converts from a file path by splitting on both @/@ and @\\@. 29 | fromFilePath :: FilePath -> Path 30 | fromFilePath = fromStrings <<< Windows.splitDirectories 31 | 32 | fromStrings :: [String] -> Path 33 | fromStrings = Path 34 | 35 | -- | Converts to a file path by joining with @/@. 36 | toFilePath :: Path -> String 37 | toFilePath = Posix.joinPath <<< toStrings 38 | 39 | toStrings :: Path -> [String] 40 | toStrings (Path strings) = strings 41 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/Revision.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Revision where 2 | 3 | import qualified Database.SQLite.Simple.ToField as Sql 4 | import Monadoc.Prelude 5 | import qualified Text.Read as Read 6 | 7 | newtype Revision 8 | = Revision Word 9 | deriving (Eq, Show) 10 | 11 | instance Sql.ToField Revision where 12 | toField = Sql.toField <<< toWord 13 | 14 | fromString :: String -> Maybe Revision 15 | fromString = map Revision <<< Read.readMaybe 16 | 17 | fromWord :: Word -> Revision 18 | fromWord = Revision 19 | 20 | increment :: Revision -> Revision 21 | increment = fromWord <<< (+ 1) <<< toWord 22 | 23 | toString :: Revision -> String 24 | toString = show <<< toWord 25 | 26 | toWord :: Revision -> Word 27 | toWord (Revision word) = word 28 | 29 | zero :: Revision 30 | zero = fromWord 0 31 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/Route.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Route where 2 | import Monadoc.Prelude 3 | 4 | -- | All of the routes that are reachable from the server. Unless otherwise 5 | -- noted, routes probably respond to HTTP GET requests. It is expected that 6 | -- each route @R@ has a corresponding handler at @Monadoc.Handler.R@. 7 | data Route 8 | = Account 9 | | Favicon 10 | | GitHubCallback 11 | | Index 12 | | Logo 13 | | LogOut -- ^ POST 14 | | Ping 15 | | Robots 16 | | Search 17 | | Tachyons 18 | | Throw 19 | deriving (Eq, Show) 20 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/Service.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Service where 2 | import Monadoc.Prelude 3 | 4 | data Service 5 | = Server 6 | | Worker 7 | deriving (Eq, Ord, Show) 8 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/Sha256.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Sha256 where 2 | 3 | import qualified Crypto.Hash as Crypto 4 | import qualified Database.SQLite.Simple.FromField as Sql 5 | import qualified Database.SQLite.Simple.ToField as Sql 6 | import Monadoc.Prelude hiding (fromString) 7 | import qualified Monadoc.Utility.Sql as Sql 8 | import qualified Text.Read as Read 9 | 10 | -- | A 256-bit digest from the Secure Hash Algorithm 2 (SHA-2). This is backed 11 | -- by a 'Crypto.Digest', specifically 'Crypto.SHA256'. Use 'fromDigest' and 12 | -- 'toDigest' to convert to and from this type. This algorithm was selected as 13 | -- a good balance between fast methods like MD5 and cryptographically secure 14 | -- ones like SHA3-512. 15 | newtype Sha256 16 | = Sha256 (Crypto.Digest Crypto.SHA256) 17 | deriving (Eq, Show) 18 | 19 | instance Sql.FromField Sha256 where 20 | fromField = Sql.fromFieldVia fromString 21 | 22 | instance Sql.ToField Sha256 where 23 | toField = Sql.toField <<< toString 24 | 25 | fromDigest :: Crypto.Digest Crypto.SHA256 -> Sha256 26 | fromDigest = Sha256 27 | 28 | fromString :: String -> Maybe Sha256 29 | fromString = map fromDigest <<< Read.readMaybe 30 | 31 | toDigest :: Sha256 -> Crypto.Digest Crypto.SHA256 32 | toDigest (Sha256 digest) = digest 33 | 34 | toString :: Sha256 -> String 35 | toString = show <<< toDigest 36 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/Size.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Size where 2 | 3 | import qualified Database.SQLite.Simple.FromField as Sql 4 | import qualified Database.SQLite.Simple.ToField as Sql 5 | import Monadoc.Prelude 6 | 7 | -- | The size of something in bytes. Although this is backed by an 'Int', by 8 | -- convention it is never negative. It uses an 'Int' because most functions 9 | -- that produce a size return 'Int's. Use 'fromInt' and 'toInt' to do 10 | -- conversions. 11 | newtype Size 12 | = Size Int 13 | deriving (Eq, Show) 14 | 15 | instance Sql.FromField Size where 16 | fromField = map fromInt <<< Sql.fromField 17 | 18 | instance Sql.ToField Size where 19 | toField = Sql.toField <<< toInt 20 | 21 | fromInt :: Int -> Size 22 | fromInt = Size 23 | 24 | toInt :: Size -> Int 25 | toInt (Size int) = int 26 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/TestException.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.TestException where 2 | 3 | import qualified Control.Monad.Catch as Exception 4 | import Monadoc.Prelude 5 | 6 | data TestException 7 | = TestException 8 | deriving (Eq, Show) 9 | 10 | instance Exception.Exception TestException 11 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/Timestamp.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Timestamp where 2 | 3 | import qualified Data.Time as Time 4 | import qualified Database.SQLite.Simple.FromField as Sql 5 | import qualified Database.SQLite.Simple.ToField as Sql 6 | import Monadoc.Prelude 7 | import qualified Monadoc.Utility.Sql as Sql 8 | import qualified Monadoc.Utility.Time as Time 9 | 10 | -- | A moment in time. This is a wrapper around 'Time.UTCTime'. Use 11 | -- 'fromUtcTime' and 'toUtcTime' to wrap and unwrap these values. Since this 12 | -- only uses UTC time, be careful with time zones when converting! 13 | newtype Timestamp 14 | = Timestamp Time.UTCTime 15 | deriving (Eq, Ord, Show) 16 | 17 | instance Sql.FromField Timestamp where 18 | fromField = 19 | Sql.fromFieldVia <| map fromUtcTime <<< Time.parse "%Y-%m-%dT%H:%M:%S%QZ" 20 | 21 | instance Sql.ToField Timestamp where 22 | toField = Sql.toField <<< Time.format "%Y-%m-%dT%H:%M:%S%3QZ" <<< toUtcTime 23 | 24 | fromUtcTime :: Time.UTCTime -> Timestamp 25 | fromUtcTime = Timestamp 26 | 27 | toUtcTime :: Timestamp -> Time.UTCTime 28 | toUtcTime (Timestamp utcTime) = utcTime 29 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/Url.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Url where 2 | 3 | import qualified Database.SQLite.Simple.FromField as Sql 4 | import qualified Database.SQLite.Simple.ToField as Sql 5 | import Monadoc.Prelude 6 | import qualified Monadoc.Utility.Sql as Sql 7 | import qualified Network.URI as Uri 8 | 9 | -- | A uniform resource locator. Behind the scenes this is a 'Uri.URI'. Use 10 | -- 'fromUri' and 'toUri' to convert into and out of this type. Note that 11 | -- internationalized resource identifiers (IRIs) are not supported. 12 | newtype Url 13 | = Url Uri.URI 14 | deriving (Eq, Show) 15 | 16 | instance Sql.FromField Url where 17 | fromField = Sql.fromFieldVia <| map fromUri <<< Uri.parseURI 18 | 19 | instance Sql.ToField Url where 20 | toField = Sql.toField <<< (<| "") <<< Uri.uriToString identity <<< toUri 21 | 22 | fromUri :: Uri.URI -> Url 23 | fromUri = Url 24 | 25 | toUri :: Url -> Uri.URI 26 | toUri (Url uri) = uri 27 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/User.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.User where 2 | 3 | import qualified Data.Text as Text 4 | import qualified Database.SQLite.Simple as Sql 5 | import qualified Database.SQLite.Simple.ToField as Sql 6 | import Monadoc.Prelude 7 | import qualified Monadoc.Type.GitHub.Login as Login 8 | import qualified Monadoc.Type.GitHub.UserId as UserId 9 | import qualified Monadoc.Type.Guid as Guid 10 | 11 | data User = User 12 | { guid :: Guid.Guid 13 | , id :: UserId.UserId 14 | , login :: Login.Login 15 | , token :: Text.Text 16 | } deriving (Eq, Show) 17 | 18 | instance Sql.FromRow User where 19 | fromRow = do 20 | theGuid <- Sql.field 21 | theId <- Sql.field 22 | theLogin <- Sql.field 23 | theToken <- Sql.field 24 | pure User 25 | { guid = theGuid 26 | , id = theId 27 | , login = theLogin 28 | , token = theToken 29 | } 30 | 31 | instance Sql.ToRow User where 32 | toRow user = 33 | [ Sql.toField <| guid user 34 | , Sql.toField <| id user 35 | , Sql.toField <| login user 36 | , Sql.toField <| token user 37 | ] 38 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Type/WithCallStack.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.WithCallStack where 2 | 3 | import qualified Control.Monad.Catch as Exception 4 | import qualified Data.Function as Function 5 | import qualified GHC.Stack as Stack 6 | import Monadoc.Prelude 7 | 8 | -- | Some value with a 'Stack.CallStack' attached. Typically this is used with 9 | -- 'Exception.SomeException' to attach call stacks to exceptions. 10 | data WithCallStack a = WithCallStack 11 | { callStack :: Stack.CallStack 12 | , value :: a 13 | } deriving Show 14 | 15 | instance Eq a => Eq (WithCallStack a) where 16 | x == y = 17 | Function.on (==) (Stack.getCallStack <<< callStack) x y 18 | && Function.on (==) value x y 19 | 20 | instance Exception.Exception e => Exception.Exception (WithCallStack e) where 21 | displayException x = 22 | let string = Exception.displayException <| value x 23 | in 24 | case Stack.prettyCallStack <| callStack x of 25 | "" -> string 26 | stack -> fold [string, "\n", stack] 27 | 28 | -- | Catches an exception, removing call stacks as necessary. This wraps 29 | -- 'withoutCallStack' to make it easy to catch an exception without a call 30 | -- stack even if it was thrown with one. You should prefer this over 31 | -- 'Exception.catch' when possible. 32 | catch 33 | :: (Exception.MonadCatch m, Exception.Exception e) 34 | => m a 35 | -> (e -> m a) 36 | -> m a 37 | catch x f = Exception.catches 38 | x 39 | [ Exception.Handler f 40 | , Exception.Handler <| \se -> 41 | case Exception.fromException <| withoutCallStack se of 42 | Just e -> f e 43 | Nothing -> Exception.throwM se 44 | ] 45 | 46 | -- | Throws an exception with a call stack. This wraps 'withCallStack' and 47 | -- should be preferred over 'Exception.throwM' whenever possible. 48 | throw 49 | :: (Stack.HasCallStack, Exception.Exception e, Exception.MonadThrow m) 50 | => e 51 | -> m a 52 | throw = Exception.throwM <<< withCallStack <<< Exception.toException 53 | 54 | -- | Adds a call stack if there isn't one already. Whatever calls this function 55 | -- should probably have a 'Stack.HasCallStack' constraint. Instead of calling 56 | -- this function directly, consider calling 'throw' instead. 57 | withCallStack 58 | :: Stack.HasCallStack => Exception.SomeException -> Exception.SomeException 59 | withCallStack x = case Exception.fromException x of 60 | Just (WithCallStack _ (Exception.SomeException _)) -> x 61 | Nothing -> Exception.toException WithCallStack 62 | { callStack = Stack.popCallStack Stack.callStack 63 | , value = x 64 | } 65 | 66 | -- | Removes any call stacks. Instead of calling this function directly, 67 | -- consider using 'catch' instead. 68 | withoutCallStack :: Exception.SomeException -> Exception.SomeException 69 | withoutCallStack e1 = case Exception.fromException e1 of 70 | Just (WithCallStack _ e2) -> withoutCallStack e2 71 | Nothing -> e1 72 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Utility/Cabal.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Utility.Cabal where 2 | 3 | import qualified Data.ByteString as ByteString 4 | import qualified Data.Function as Function 5 | import qualified Data.List.NonEmpty as NonEmpty 6 | import qualified Distribution.PackageDescription.Parsec as Cabal 7 | import qualified Distribution.Parsec.Error as Cabal 8 | import qualified Distribution.Types.GenericPackageDescription as Cabal 9 | import Monadoc.Prelude 10 | 11 | newtype Errors = Errors 12 | { unwrapErrors :: NonEmpty.NonEmpty Cabal.PError 13 | } deriving Show 14 | 15 | instance Eq Errors where 16 | (==) = Function.on (==) show 17 | 18 | newtype Package = Package 19 | { unwrapPackage :: Cabal.GenericPackageDescription 20 | } deriving (Eq, Show) 21 | 22 | parse :: ByteString.ByteString -> Either Errors Package 23 | parse byteString = 24 | let parseResult = Cabal.parseGenericPackageDescription byteString 25 | in 26 | case snd <| Cabal.runParseResult parseResult of 27 | Left (_, x) -> Left <| Errors x 28 | Right x -> Right <| Package x 29 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Utility/Console.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Utility.Console where 2 | 3 | import qualified Control.Concurrent.STM as Stm 4 | import qualified Control.Monad.Catch as Exception 5 | import qualified Control.Monad.IO.Class as IO 6 | import qualified Data.Time as Time 7 | import Monadoc.Prelude 8 | import qualified Monadoc.Utility.Time as Time 9 | import qualified System.IO as IO 10 | import qualified System.IO.Unsafe as Unsafe 11 | 12 | -- | Puts a timestamp in front of the given message and logs it to STDOUT. 13 | -- Ensures that only one thread outputs at a time, so output won't be garbled 14 | -- when running on multiple threads. 15 | info :: IO.MonadIO m => String -> m () 16 | info = logOn IO.stdout 17 | 18 | -- | Just like 'info' but on STDERR instead of STDOUT. 19 | warn :: IO.MonadIO m => String -> m () 20 | warn = logOn IO.stderr 21 | 22 | logOn :: IO.MonadIO m => IO.Handle -> String -> m () 23 | logOn h message = do 24 | now <- IO.liftIO Time.getCurrentTime 25 | IO.liftIO 26 | <<< Exception.bracket 27 | (Stm.atomically <| Stm.takeTMVar logVar) 28 | (Stm.atomically <<< Stm.putTMVar logVar) 29 | <| \() -> IO.liftIO <<< IO.hPutStrLn h <| unwords 30 | [Time.format "%Y-%m-%dT%H:%M:%S%3QZ" now, message] 31 | 32 | logVar :: Stm.TMVar () 33 | logVar = Unsafe.unsafePerformIO <| Stm.newTMVarIO () 34 | {-# NOINLINE logVar #-} 35 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Utility/Ghc.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Utility.Ghc where 2 | 3 | import qualified Bag 4 | import qualified Control.Exception 5 | import qualified Control.Monad 6 | import qualified Data.ByteString 7 | import qualified Data.Function 8 | import qualified Data.Text 9 | import qualified DynFlags 10 | import qualified ErrUtils 11 | import qualified FastString 12 | import qualified GHC 13 | import qualified GHC.Hs 14 | import qualified GHC.LanguageExtensions.Type as X 15 | import qualified GHC.Paths 16 | import qualified HeaderInfo 17 | import qualified Language.Preprocessor.Cpphs as Cpp 18 | import qualified Lexer 19 | import Monadoc.Prelude 20 | import qualified Monadoc.Utility.Utf8 as Utf8 21 | import qualified Outputable 22 | import qualified Parser 23 | import qualified SrcLoc 24 | import qualified StringBuffer 25 | 26 | newtype Errors = Errors 27 | { unwrapErrors :: Bag.Bag ErrUtils.ErrMsg 28 | } 29 | 30 | instance Eq Errors where 31 | (==) = Data.Function.on (==) show 32 | 33 | instance Show Errors where 34 | show = show <<< Bag.bagToList <<< unwrapErrors 35 | 36 | newtype Module = Module 37 | { unwrapModule :: SrcLoc.Located (GHC.Hs.HsModule GHC.Hs.GhcPs) 38 | } 39 | 40 | instance Eq Module where 41 | (==) = Data.Function.on (==) show 42 | 43 | instance Show Module where 44 | show = Outputable.showSDocUnsafe <<< Outputable.ppr <<< unwrapModule 45 | 46 | parse 47 | :: [(Bool, X.Extension)] 48 | -> FilePath 49 | -> Data.ByteString.ByteString 50 | -> IO (Either Errors Module) 51 | parse extensions filePath byteString = Control.Exception.handle handler <| do 52 | dynFlags1 <- GHC.runGhc (Just GHC.Paths.libdir) GHC.getSessionDynFlags 53 | let 54 | dynFlags2 = foldr 55 | toggleExtension 56 | (DynFlags.gopt_set dynFlags1 DynFlags.Opt_KeepRawTokenStream) 57 | extensions 58 | let text = Utf8.toText byteString 59 | let string1 = Data.Text.unpack text 60 | let stringBuffer1 = StringBuffer.stringToStringBuffer string1 61 | let locatedStrings = HeaderInfo.getOptions dynFlags2 stringBuffer1 filePath 62 | (dynFlags3, _, _) <- DynFlags.parseDynamicFilePragma dynFlags2 locatedStrings 63 | string2 <- if DynFlags.xopt X.Cpp dynFlags3 64 | then Cpp.runCpphs cpphsOptions filePath string1 65 | else pure string1 66 | Control.Monad.void <<< Control.Exception.evaluate <| length string2 67 | let stringBuffer2 = StringBuffer.stringToStringBuffer string2 68 | let fastString = FastString.mkFastString filePath 69 | let realSrcLoc = SrcLoc.mkRealSrcLoc fastString 1 1 70 | let pState1 = Lexer.mkPState dynFlags3 stringBuffer2 realSrcLoc 71 | pure <| case Lexer.unP Parser.parseModule pState1 of 72 | Lexer.PFailed pState2 -> 73 | Left <<< Errors <<< snd <| Lexer.getMessages pState2 dynFlags3 74 | Lexer.POk pState2 locatedHsModuleGhcPs -> 75 | let bagErrMsg = snd <| Lexer.getMessages pState2 dynFlags3 76 | in 77 | if blank bagErrMsg 78 | then Right <| Module locatedHsModuleGhcPs 79 | else Left <| Errors bagErrMsg 80 | 81 | cpphsOptions :: Cpp.CpphsOptions 82 | cpphsOptions = Cpp.defaultCpphsOptions 83 | { Cpp.boolopts = Cpp.defaultBoolOptions { Cpp.warnings = False } 84 | , Cpp.defines = [] -- TODO 85 | } 86 | 87 | handler :: Control.Exception.SomeException -> IO (Either Errors Module) 88 | handler e = do 89 | f <- GHC.runGhc (Just GHC.Paths.libdir) GHC.getSessionDynFlags 90 | pure 91 | <<< Left 92 | <<< Errors 93 | <<< Bag.unitBag 94 | <<< ErrUtils.mkPlainErrMsg f SrcLoc.noSrcSpan 95 | <<< Outputable.text 96 | <| show e 97 | 98 | toggleExtension 99 | :: (Bool, X.Extension) -> DynFlags.DynFlags -> DynFlags.DynFlags 100 | toggleExtension (enable, extension) = 101 | if enable then enableExtension extension else disableExtension extension 102 | 103 | enableExtension :: X.Extension -> DynFlags.DynFlags -> DynFlags.DynFlags 104 | enableExtension extension oldFlags = 105 | foldr toggleExtension (DynFlags.xopt_set oldFlags extension) 106 | <| impliedExtensions extension 107 | 108 | disableExtension :: X.Extension -> DynFlags.DynFlags -> DynFlags.DynFlags 109 | disableExtension = flip DynFlags.xopt_unset 110 | 111 | -- | 112 | impliedExtensions :: X.Extension -> [(Bool, X.Extension)] 113 | impliedExtensions extension = case extension of 114 | X.AutoDeriveTypeable -> [(True, X.DeriveDataTypeable)] 115 | X.DeriveTraversable -> [(True, X.DeriveFoldable), (True, X.DeriveFunctor)] 116 | X.DerivingVia -> [(True, X.DerivingStrategies)] 117 | X.DuplicateRecordFields -> [(True, X.DisambiguateRecordFields)] 118 | X.ExistentialQuantification -> [(True, X.ExplicitForAll)] 119 | X.FlexibleInstances -> [(True, X.TypeSynonymInstances)] 120 | X.FunctionalDependencies -> [(True, X.MultiParamTypeClasses)] 121 | X.GADTs -> [(True, X.GADTSyntax), (True, X.MonoLocalBinds)] 122 | X.ImpredicativeTypes -> [(True, X.RankNTypes)] 123 | X.JavaScriptFFI -> [(True, X.InterruptibleFFI)] 124 | X.LiberalTypeSynonyms -> [(True, X.ExplicitForAll)] 125 | X.MultiParamTypeClasses -> [(True, X.ConstrainedClassMethods)] 126 | X.ParallelArrays -> [(True, X.ParallelListComp)] 127 | X.PolyKinds -> [(True, X.KindSignatures)] 128 | X.QuantifiedConstraints -> [(True, X.ExplicitForAll)] 129 | X.RankNTypes -> [(True, X.ExplicitForAll)] 130 | X.RebindableSyntax -> [(False, X.ImplicitPrelude)] 131 | X.RecordWildCards -> [(True, X.DisambiguateRecordFields)] 132 | X.ScopedTypeVariables -> [(True, X.ExplicitForAll)] 133 | X.StandaloneKindSignatures -> [(False, X.CUSKs)] 134 | X.Strict -> [(True, X.StrictData)] 135 | X.TemplateHaskell -> [(True, X.TemplateHaskellQuotes)] 136 | X.TypeFamilies -> 137 | [ (True, X.ExplicitNamespaces) 138 | , (True, X.KindSignatures) 139 | , (True, X.MonoLocalBinds) 140 | ] 141 | X.TypeFamilyDependencies -> [(True, X.TypeFamilies)] 142 | X.TypeInType -> 143 | [(True, X.DataKinds), (True, X.KindSignatures), (True, X.PolyKinds)] 144 | X.TypeOperators -> [(True, X.ExplicitNamespaces)] 145 | _ -> [] 146 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Utility/Sql.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Utility.Sql where 2 | 3 | import qualified Data.Typeable as Typeable 4 | import qualified Database.SQLite.Simple as Sql 5 | import qualified Database.SQLite.Simple.FromField as Sql 6 | import qualified Database.SQLite.Simple.Ok as Sql 7 | import Monadoc.Prelude 8 | 9 | -- | Converts from a SQL field into a value using the given function. This is 10 | -- mostly used to avoid all the boilerplate. 11 | fromFieldVia 12 | :: (Sql.FromField a, Show a, Typeable.Typeable b) 13 | => (a -> Maybe b) 14 | -> Sql.Field 15 | -> Sql.Ok b 16 | fromFieldVia f x = do 17 | y <- Sql.fromField x 18 | case f y of 19 | Nothing -> 20 | Sql.returnError Sql.ConversionFailed x <| "failed to convert " <> show y 21 | Just z -> pure z 22 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Utility/Time.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Utility.Time where 2 | 3 | import qualified Data.Fixed as Fixed 4 | import qualified Data.Time as Time 5 | import Monadoc.Prelude 6 | 7 | -- | Uses a format string to format a time value. Uses the 8 | -- 'Time.defaultTimeLocale'. 9 | format :: Time.FormatTime t => String -> t -> String 10 | format = Time.formatTime Time.defaultTimeLocale 11 | 12 | -- | Uses a format string to parse a time string. Uses the 13 | -- 'Time.defaultTimeLocale'. 14 | parse :: Time.ParseTime t => String -> String -> Maybe t 15 | parse = Time.parseTimeM False Time.defaultTimeLocale 16 | 17 | -- | Builds a 'Time.UTCTime' using the given year, month, day, hour, minute, 18 | -- and second. Date values that are out of bounds will be clamped. Time values 19 | -- that are out of bounds will be left alone. 20 | utcTime :: Integer -> Int -> Int -> Int -> Int -> Fixed.Pico -> Time.UTCTime 21 | utcTime year month day hour minute second = Time.UTCTime 22 | { Time.utctDay = Time.fromGregorian year month day 23 | , Time.utctDayTime = Time.timeOfDayToTime Time.TimeOfDay 24 | { Time.todHour = hour 25 | , Time.todMin = minute 26 | , Time.todSec = second 27 | } 28 | } 29 | -------------------------------------------------------------------------------- /src/lib/Monadoc/Utility/Utf8.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Utility.Utf8 where 2 | 3 | import qualified Data.ByteString as ByteString 4 | import qualified Data.Text as Text 5 | import qualified Data.Text.Encoding as Text 6 | import qualified Data.Text.Encoding.Error as Text 7 | import Monadoc.Prelude 8 | 9 | -- | Converts a string into a UTF-8 encoded byte string. See 'fromText'. 10 | fromString :: String -> ByteString.ByteString 11 | fromString = fromText <<< Text.pack 12 | 13 | -- | Converts text into a UTF-8 encoded byte string. 14 | fromText :: Text.Text -> ByteString.ByteString 15 | fromText = Text.encodeUtf8 16 | 17 | -- | Converts a UTF-8 encoded byte string into a string. See 'toText'. 18 | toString :: ByteString.ByteString -> String 19 | toString = Text.unpack <<< toText 20 | 21 | -- | Converts a UTF-8 byte string into text, assuming that the bytes are UTF-8. 22 | -- Any invalid bytes will be replaced with U+FFFD, the Unicode replacement 23 | -- character. 24 | toText :: ByteString.ByteString -> Text.Text 25 | toText = Text.decodeUtf8With Text.lenientDecode 26 | -------------------------------------------------------------------------------- /src/script/brittany.hs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env stack 2 | -- stack exec --package Glob --package process runghc 3 | import qualified System.FilePath.Glob as Glob 4 | import qualified System.IO as IO 5 | import qualified System.Process as Process 6 | 7 | main :: IO () 8 | main = do 9 | files <- Glob.glob "src/**/*.hs" 10 | mapM_ (convertNewlinesTo IO.LF) files 11 | Process.callProcess "brittany" 12 | $ "--config-file=config/brittany.yaml" 13 | : "--write-mode=inplace" 14 | : files 15 | mapM_ (convertNewlinesTo IO.nativeNewline) files 16 | 17 | convertNewlinesTo :: IO.Newline -> FilePath -> IO () 18 | convertNewlinesTo newline file = do 19 | contents <- IO.withFile file IO.ReadMode $ \handle -> do 20 | IO.hSetNewlineMode handle IO.universalNewlineMode 21 | contents <- IO.hGetContents handle 22 | () <- seq (length contents) $ pure () 23 | pure contents 24 | IO.withFile file IO.WriteMode $ \handle -> do 25 | IO.hSetNewlineMode handle $ IO.NewlineMode newline newline 26 | IO.hPutStr handle contents 27 | -------------------------------------------------------------------------------- /src/script/ghcid.hs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env stack 2 | -- stack exec --package process runghc 3 | import qualified System.Process as Process 4 | 5 | main :: IO () 6 | main = Process.callProcess 7 | "ghcid" 8 | [ "--command=stack ghci" 9 | , "--reload=monadoc.cabal" 10 | , "--test=:main --services server" 11 | , "--warnings" 12 | ] 13 | -------------------------------------------------------------------------------- /src/script/hlint.hs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env stack 2 | -- stack exec --package Glob --package process runghc 3 | import qualified System.FilePath.Glob as Glob 4 | import qualified System.Process as Process 5 | 6 | main :: IO () 7 | main = do 8 | files <- Glob.glob "src/**/*.hs" 9 | Process.callProcess "hlint" $ "--hint=config/hlint.yaml" : files 10 | -------------------------------------------------------------------------------- /src/script/purple-yolk.hs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env stack 2 | -- stack exec --package process runghc 3 | import qualified System.Process as Process 4 | 5 | main :: IO () 6 | main = Process.callProcess 7 | "stack" 8 | [ "--color=never" 9 | , "ghci" 10 | , "--ghc-options=-ddump-json" 11 | , "--ghc-options=-fdefer-type-errors" 12 | , "--ghc-options=-fmax-relevant-binds=0" 13 | , "--ghc-options=-fno-diagnostics-show-caret" 14 | , "--ghc-options=-fobject-code" 15 | , "--ghc-options=-funclutter-valid-hole-fits" 16 | , "--ghc-options=-j4" 17 | , "--ghc-options=-O0" 18 | , "--main-is=monadoc:test" 19 | , "--test" 20 | ] 21 | -------------------------------------------------------------------------------- /src/script/set-commit-hash.hs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env stack 2 | -- stack exec runghc 3 | import qualified Data.Text as Text 4 | import qualified Data.Text.IO as Text 5 | import qualified System.Environment as Environment 6 | 7 | -- | This script replaces the literal string @Nothing@ in a file with the given 8 | -- string. It's like a very limited version of @sed@. It's used to put the Git 9 | -- commit hash into a source file when building on CI. Typical usage looks like 10 | -- this: 11 | -- 12 | -- > runghc src/script/set-commit-hash.hs \ 13 | -- > src/lib/Monadoc/Data/Commit.hs \ 14 | -- > $GITHUB_SHA # or ${{ github.sha }} 15 | -- 16 | -- For that invocation, let's say @$GITHUB_SHA@ is @01af@. That means the 17 | -- source file will have any instances of @Nothing@ replaced with 18 | -- @(Just "01af")@. 19 | -- 20 | -- Why do we do things this way? Originally we used the @githash@ package. That 21 | -- spliced in Git information using Template Haskell. It did so by looking for 22 | -- specific files. Unfortunately Cabal's Nix-style builds don't include Git 23 | -- stuff, so the information was never populated. 24 | -- 25 | -- That motivated us to look at CPP solutions. However we quickly ran into two 26 | -- problems: Escaping strings is hard, and passing options is tedious. Trying 27 | -- to get a quoted string through all the layers of build tools was basically 28 | -- impossible. Passing a bare string worked but required escaping with a macro. 29 | -- That would only work if we used @cpphs@ instead of the default. And then on 30 | -- top of all that Cabal makes it very hard to set a GHC option for only one 31 | -- package. 32 | -- 33 | -- We briefly considering a TH solution that read an environment variable. 34 | -- Ultimately we decided against that because it wasn't clear how to avoid 35 | -- accidentally caching the wrong information, or causing it to rebuild more 36 | -- frequently than necessary. 37 | -- 38 | -- So that's how we ended up here. We chose to write a small Haskell script 39 | -- instead of using @sed@ so that it would work across operating systems. 40 | main :: IO () 41 | main = do 42 | [file, hash] <- Environment.getArgs 43 | contents <- Text.readFile file 44 | Text.writeFile file $ Text.replace 45 | (Text.pack "Nothing") 46 | (Text.pack $ mconcat ["(Just ", show hash, ")"]) 47 | contents 48 | -------------------------------------------------------------------------------- /src/script/stylish-haskell.hs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env stack 2 | -- stack exec --package Glob --package process runghc 3 | import qualified System.FilePath.Glob as Glob 4 | import qualified System.Process as Process 5 | 6 | main :: IO () 7 | main = do 8 | files <- Glob.glob "src/**/*.hs" 9 | Process.callProcess "stylish-haskell" 10 | $ "--config=config/stylish-haskell.yaml" 11 | : "--inplace" 12 | : files 13 | -------------------------------------------------------------------------------- /src/test/Main.hs: -------------------------------------------------------------------------------- 1 | import qualified Monadoc.Data.CommitSpec 2 | import qualified Monadoc.Data.MigrationsSpec 3 | import qualified Monadoc.Data.OptionsSpec 4 | import qualified Monadoc.Data.VersionSpec 5 | import qualified Monadoc.Handler.AccountSpec 6 | import qualified Monadoc.Handler.FaviconSpec 7 | import qualified Monadoc.Handler.GitHubCallbackSpec 8 | import qualified Monadoc.Handler.IndexSpec 9 | import qualified Monadoc.Handler.LogoSpec 10 | import qualified Monadoc.Handler.LogOutSpec 11 | import qualified Monadoc.Handler.PingSpec 12 | import qualified Monadoc.Handler.RobotsSpec 13 | import qualified Monadoc.Handler.SearchSpec 14 | import qualified Monadoc.Handler.TachyonsSpec 15 | import qualified Monadoc.Handler.ThrowSpec 16 | import qualified Monadoc.MainSpec 17 | import Monadoc.Prelude 18 | import qualified Monadoc.Server.ApplicationSpec 19 | import qualified Monadoc.Server.CommonSpec 20 | import qualified Monadoc.Server.MainSpec 21 | import qualified Monadoc.Server.MiddlewareSpec 22 | import qualified Monadoc.Server.RouterSpec 23 | import qualified Monadoc.Server.SettingsSpec 24 | import qualified Monadoc.Server.TemplateSpec 25 | import qualified Monadoc.Type.AppSpec 26 | import qualified Monadoc.Type.BinarySpec 27 | import qualified Monadoc.Type.Cabal.ModuleNameSpec 28 | import qualified Monadoc.Type.Cabal.PackageNameSpec 29 | import qualified Monadoc.Type.Cabal.VersionRangeSpec 30 | import qualified Monadoc.Type.Cabal.VersionSpec 31 | import qualified Monadoc.Type.ConfigResultSpec 32 | import qualified Monadoc.Type.ConfigSpec 33 | import qualified Monadoc.Type.ContextSpec 34 | import qualified Monadoc.Type.EtagSpec 35 | import qualified Monadoc.Type.GitHub.LoginSpec 36 | import qualified Monadoc.Type.GitHub.UserIdSpec 37 | import qualified Monadoc.Type.GitHub.UserSpec 38 | import qualified Monadoc.Type.GuidSpec 39 | import qualified Monadoc.Type.MigrationMismatchSpec 40 | import qualified Monadoc.Type.MigrationSpec 41 | import qualified Monadoc.Type.NotFoundExceptionSpec 42 | import qualified Monadoc.Type.PathSpec 43 | import qualified Monadoc.Type.RevisionSpec 44 | import qualified Monadoc.Type.RouteSpec 45 | import qualified Monadoc.Type.ServiceSpec 46 | import qualified Monadoc.Type.Sha256Spec 47 | import qualified Monadoc.Type.SizeSpec 48 | import qualified Monadoc.Type.TestExceptionSpec 49 | import qualified Monadoc.Type.TimestampSpec 50 | import qualified Monadoc.Type.UrlSpec 51 | import qualified Monadoc.Type.UserSpec 52 | import qualified Monadoc.Type.WithCallStackSpec 53 | import qualified Monadoc.Utility.CabalSpec 54 | import qualified Monadoc.Utility.ConsoleSpec 55 | import qualified Monadoc.Utility.GhcSpec 56 | import qualified Monadoc.Utility.SqlSpec 57 | import qualified Monadoc.Utility.TimeSpec 58 | import qualified Monadoc.Utility.Utf8Spec 59 | import qualified Monadoc.Worker.MainSpec 60 | import qualified MonadocSpec 61 | import Test.Hspec 62 | 63 | main :: IO () 64 | main = hspec <| do 65 | Monadoc.Data.CommitSpec.spec 66 | Monadoc.Data.MigrationsSpec.spec 67 | Monadoc.Data.OptionsSpec.spec 68 | Monadoc.Data.VersionSpec.spec 69 | Monadoc.Handler.AccountSpec.spec 70 | Monadoc.Handler.FaviconSpec.spec 71 | Monadoc.Handler.GitHubCallbackSpec.spec 72 | Monadoc.Handler.IndexSpec.spec 73 | Monadoc.Handler.LogoSpec.spec 74 | Monadoc.Handler.LogOutSpec.spec 75 | Monadoc.Handler.PingSpec.spec 76 | Monadoc.Handler.RobotsSpec.spec 77 | Monadoc.Handler.SearchSpec.spec 78 | Monadoc.Handler.TachyonsSpec.spec 79 | Monadoc.Handler.ThrowSpec.spec 80 | Monadoc.MainSpec.spec 81 | Monadoc.Server.ApplicationSpec.spec 82 | Monadoc.Server.CommonSpec.spec 83 | Monadoc.Server.MainSpec.spec 84 | Monadoc.Server.MiddlewareSpec.spec 85 | Monadoc.Server.RouterSpec.spec 86 | Monadoc.Server.SettingsSpec.spec 87 | Monadoc.Server.TemplateSpec.spec 88 | Monadoc.Type.AppSpec.spec 89 | Monadoc.Type.BinarySpec.spec 90 | Monadoc.Type.Cabal.ModuleNameSpec.spec 91 | Monadoc.Type.Cabal.PackageNameSpec.spec 92 | Monadoc.Type.Cabal.VersionRangeSpec.spec 93 | Monadoc.Type.Cabal.VersionSpec.spec 94 | Monadoc.Type.ConfigResultSpec.spec 95 | Monadoc.Type.ConfigSpec.spec 96 | Monadoc.Type.ContextSpec.spec 97 | Monadoc.Type.EtagSpec.spec 98 | Monadoc.Type.GitHub.LoginSpec.spec 99 | Monadoc.Type.GitHub.UserIdSpec.spec 100 | Monadoc.Type.GitHub.UserSpec.spec 101 | Monadoc.Type.GuidSpec.spec 102 | Monadoc.Type.MigrationMismatchSpec.spec 103 | Monadoc.Type.MigrationSpec.spec 104 | Monadoc.Type.NotFoundExceptionSpec.spec 105 | Monadoc.Type.PathSpec.spec 106 | Monadoc.Type.RevisionSpec.spec 107 | Monadoc.Type.RouteSpec.spec 108 | Monadoc.Type.ServiceSpec.spec 109 | Monadoc.Type.Sha256Spec.spec 110 | Monadoc.Type.SizeSpec.spec 111 | Monadoc.Type.TestExceptionSpec.spec 112 | Monadoc.Type.TimestampSpec.spec 113 | Monadoc.Type.UrlSpec.spec 114 | Monadoc.Type.UserSpec.spec 115 | Monadoc.Type.WithCallStackSpec.spec 116 | Monadoc.Utility.CabalSpec.spec 117 | Monadoc.Utility.ConsoleSpec.spec 118 | Monadoc.Utility.GhcSpec.spec 119 | Monadoc.Utility.SqlSpec.spec 120 | Monadoc.Utility.TimeSpec.spec 121 | Monadoc.Utility.Utf8Spec.spec 122 | Monadoc.Worker.MainSpec.spec 123 | MonadocSpec.spec 124 | -------------------------------------------------------------------------------- /src/test/Monadoc/Data/CommitSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Data.CommitSpec where 2 | 3 | import qualified Monadoc.Data.Commit as Commit 4 | import Monadoc.Prelude 5 | import Test.Hspec 6 | 7 | spec :: Spec 8 | spec = describe "Monadoc.Data.Commit" <| do 9 | 10 | describe "hash" <| do 11 | 12 | it "is not null if set" <| do 13 | case Commit.hash of 14 | Nothing -> pure () 15 | Just hash -> hash `shouldSatisfy` present 16 | -------------------------------------------------------------------------------- /src/test/Monadoc/Data/MigrationsSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Data.MigrationsSpec where 2 | 3 | import qualified Monadoc.Data.Migrations as Migrations 4 | import Monadoc.Prelude 5 | import Test.Hspec 6 | 7 | spec :: Spec 8 | spec = describe "Monadoc.Data.Migrations" <| do 9 | 10 | describe "migrations" <| do 11 | 12 | it "has at least one migration" <| do 13 | Migrations.migrations `shouldSatisfy` present 14 | -------------------------------------------------------------------------------- /src/test/Monadoc/Data/OptionsSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Data.OptionsSpec where 2 | 3 | import qualified Monadoc.Data.Options as Options 4 | import Monadoc.Prelude 5 | import qualified System.Console.GetOpt as GetOpt 6 | import Test.Hspec 7 | 8 | spec :: Spec 9 | spec = describe "Monadoc.Data.Options" <| do 10 | 11 | describe "options" <| do 12 | 13 | it "has a --help option" <| do 14 | let 15 | f :: GetOpt.OptDescr a -> [String] 16 | f (GetOpt.Option _ x _ _) = x 17 | foldMap f Options.options `shouldSatisfy` elem "help" 18 | -------------------------------------------------------------------------------- /src/test/Monadoc/Data/VersionSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Data.VersionSpec where 2 | 3 | import qualified Data.Version as Version 4 | import qualified Monadoc.Data.Version as Monadoc.Version 5 | import Monadoc.Prelude 6 | import Test.Hspec 7 | 8 | spec :: Spec 9 | spec = describe "Monadoc.Data.Version" <| do 10 | 11 | describe "string" <| do 12 | 13 | it "is not null" <| do 14 | Monadoc.Version.string `shouldSatisfy` present 15 | 16 | describe "version" <| do 17 | 18 | it "has four branches" <| do 19 | Version.versionBranch Monadoc.Version.version 20 | `shouldSatisfy` ((== 4) <<< length) 21 | 22 | it "has no tags" <| do 23 | let Version.Version _ tags = Monadoc.Version.version 24 | tags `shouldSatisfy` blank 25 | -------------------------------------------------------------------------------- /src/test/Monadoc/Handler/AccountSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.AccountSpec where 2 | 3 | import qualified Monadoc 4 | import qualified Monadoc.Handler.Account as Account 5 | import Monadoc.Prelude 6 | import qualified Monadoc.Type.App as App 7 | import qualified Monadoc.Type.Config as Config 8 | import qualified Monadoc.Type.Context as Context 9 | import qualified Network.HTTP.Types as Http 10 | import qualified Network.Wai as Wai 11 | import Test.Hspec 12 | 13 | spec :: Spec 14 | spec = describe "Monadoc.Handler.Account" <| do 15 | 16 | describe "handle" <| do 17 | 18 | it "works" <| do 19 | ctx <- Monadoc.configToContext Config.test 20 | response <- App.run 21 | ctx { Context.request = Wai.defaultRequest } 22 | Account.handle 23 | Wai.responseStatus response `shouldBe` Http.found302 24 | -------------------------------------------------------------------------------- /src/test/Monadoc/Handler/FaviconSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.FaviconSpec where 2 | 3 | import qualified Monadoc 4 | import qualified Monadoc.Handler.Favicon as Favicon 5 | import Monadoc.Prelude 6 | import qualified Monadoc.Type.App as App 7 | import qualified Monadoc.Type.Config as Config 8 | import qualified Monadoc.Type.Context as Context 9 | import qualified Network.HTTP.Types as Http 10 | import qualified Network.Wai as Wai 11 | import Test.Hspec 12 | 13 | spec :: Spec 14 | spec = describe "Monadoc.Handler.Favicon" <| do 15 | 16 | describe "handle" <| do 17 | 18 | it "works" <| do 19 | ctx <- Monadoc.configToContext Config.test 20 | response <- App.run 21 | ctx { Context.request = Wai.defaultRequest } 22 | Favicon.handle 23 | Wai.responseStatus response `shouldBe` Http.ok200 24 | -------------------------------------------------------------------------------- /src/test/Monadoc/Handler/GitHubCallbackSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.GitHubCallbackSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Handler.GitHubCallback" <| do 8 | 9 | it "needs tests" pending 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Handler/IndexSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.IndexSpec where 2 | 3 | import qualified Monadoc 4 | import qualified Monadoc.Handler.Index as Index 5 | import Monadoc.Prelude 6 | import qualified Monadoc.Type.App as App 7 | import qualified Monadoc.Type.Config as Config 8 | import qualified Monadoc.Type.Context as Context 9 | import qualified Network.HTTP.Types as Http 10 | import qualified Network.Wai as Wai 11 | import Test.Hspec 12 | 13 | spec :: Spec 14 | spec = describe "Monadoc.Handler.Index" <| do 15 | 16 | describe "handle" <| do 17 | 18 | it "works" <| do 19 | ctx <- Monadoc.configToContext Config.test 20 | response <- App.run 21 | ctx { Context.request = Wai.defaultRequest } 22 | Index.handle 23 | Wai.responseStatus response `shouldBe` Http.ok200 24 | -------------------------------------------------------------------------------- /src/test/Monadoc/Handler/LogOutSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.LogOutSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Handler.LogOut" <| do 8 | 9 | it "needs tests" pending 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Handler/LogoSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.LogoSpec where 2 | 3 | import qualified Monadoc 4 | import qualified Monadoc.Handler.Logo as Logo 5 | import Monadoc.Prelude 6 | import qualified Monadoc.Type.App as App 7 | import qualified Monadoc.Type.Config as Config 8 | import qualified Monadoc.Type.Context as Context 9 | import qualified Network.HTTP.Types as Http 10 | import qualified Network.Wai as Wai 11 | import Test.Hspec 12 | 13 | spec :: Spec 14 | spec = describe "Monadoc.Handler.Logo" <| do 15 | 16 | describe "handle" <| do 17 | 18 | it "works" <| do 19 | ctx <- Monadoc.configToContext Config.test 20 | response <- App.run 21 | ctx { Context.request = Wai.defaultRequest } 22 | Logo.handle 23 | Wai.responseStatus response `shouldBe` Http.ok200 24 | -------------------------------------------------------------------------------- /src/test/Monadoc/Handler/PingSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.PingSpec where 2 | 3 | import qualified Monadoc 4 | import qualified Monadoc.Handler.Ping as Ping 5 | import Monadoc.Prelude 6 | import qualified Monadoc.Type.App as App 7 | import qualified Monadoc.Type.Config as Config 8 | import qualified Monadoc.Type.Context as Context 9 | import qualified Network.HTTP.Types as Http 10 | import qualified Network.Wai as Wai 11 | import Test.Hspec 12 | 13 | spec :: Spec 14 | spec = describe "Monadoc.Handler.Ping" <| do 15 | 16 | describe "handle" <| do 17 | 18 | it "works" <| do 19 | ctx <- Monadoc.configToContext Config.test 20 | response <- App.run 21 | ctx { Context.request = Wai.defaultRequest } 22 | Ping.handle 23 | Wai.responseStatus response `shouldBe` Http.ok200 24 | -------------------------------------------------------------------------------- /src/test/Monadoc/Handler/RobotsSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.RobotsSpec where 2 | 3 | import qualified Monadoc 4 | import qualified Monadoc.Handler.Robots as Robots 5 | import Monadoc.Prelude 6 | import qualified Monadoc.Type.App as App 7 | import qualified Monadoc.Type.Config as Config 8 | import qualified Monadoc.Type.Context as Context 9 | import qualified Network.HTTP.Types as Http 10 | import qualified Network.Wai as Wai 11 | import Test.Hspec 12 | 13 | spec :: Spec 14 | spec = describe "Monadoc.Handler.Robots" <| do 15 | 16 | describe "handle" <| do 17 | 18 | it "works" <| do 19 | ctx <- Monadoc.configToContext Config.test 20 | response <- App.run 21 | ctx { Context.request = Wai.defaultRequest } 22 | Robots.handle 23 | Wai.responseStatus response `shouldBe` Http.ok200 24 | -------------------------------------------------------------------------------- /src/test/Monadoc/Handler/SearchSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.SearchSpec where 2 | 3 | import qualified Monadoc 4 | import qualified Monadoc.Handler.Search as Search 5 | import Monadoc.Prelude 6 | import qualified Monadoc.Type.App as App 7 | import qualified Monadoc.Type.Config as Config 8 | import qualified Monadoc.Type.Context as Context 9 | import qualified Network.HTTP.Types as Http 10 | import qualified Network.Wai as Wai 11 | import Test.Hspec 12 | 13 | spec :: Spec 14 | spec = describe "Monadoc.Handler.Search" <| do 15 | 16 | describe "handle" <| do 17 | 18 | it "works" <| do 19 | ctx <- Monadoc.configToContext Config.test 20 | response <- App.run 21 | ctx { Context.request = Wai.defaultRequest } 22 | Search.handle 23 | Wai.responseStatus response `shouldBe` Http.ok200 24 | -------------------------------------------------------------------------------- /src/test/Monadoc/Handler/TachyonsSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.TachyonsSpec where 2 | 3 | import qualified Monadoc 4 | import qualified Monadoc.Handler.Tachyons as Tachyons 5 | import Monadoc.Prelude 6 | import qualified Monadoc.Type.App as App 7 | import qualified Monadoc.Type.Config as Config 8 | import qualified Monadoc.Type.Context as Context 9 | import qualified Network.HTTP.Types as Http 10 | import qualified Network.Wai as Wai 11 | import Test.Hspec 12 | 13 | spec :: Spec 14 | spec = describe "Monadoc.Handler.Tachyons" <| do 15 | 16 | describe "handle" <| do 17 | 18 | it "works" <| do 19 | ctx <- Monadoc.configToContext Config.test 20 | response <- App.run 21 | ctx { Context.request = Wai.defaultRequest } 22 | Tachyons.handle 23 | Wai.responseStatus response `shouldBe` Http.ok200 24 | -------------------------------------------------------------------------------- /src/test/Monadoc/Handler/ThrowSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Handler.ThrowSpec where 2 | 3 | import qualified Control.Monad.Catch as Exception 4 | import qualified Monadoc 5 | import qualified Monadoc.Handler.Throw as Throw 6 | import Monadoc.Prelude 7 | import qualified Monadoc.Type.App as App 8 | import qualified Monadoc.Type.Config as Config 9 | import qualified Monadoc.Type.Context as Context 10 | import qualified Monadoc.Type.TestException as TestException 11 | import qualified Monadoc.Type.WithCallStack as WithCallStack 12 | import qualified Network.Wai as Wai 13 | import Test.Hspec 14 | 15 | spec :: Spec 16 | spec = describe "Monadoc.Handler.Throw" <| do 17 | 18 | describe "handle" <| do 19 | 20 | it "works" <| do 21 | ctx <- Monadoc.configToContext Config.test 22 | let 23 | result = 24 | App.run ctx { Context.request = Wai.defaultRequest } Throw.handle 25 | result `shouldThrow` aTestException 26 | 27 | aTestException :: Exception.SomeException -> Bool 28 | aTestException = 29 | (== Just TestException.TestException) 30 | <<< Exception.fromException 31 | <<< WithCallStack.withoutCallStack 32 | -------------------------------------------------------------------------------- /src/test/Monadoc/MainSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.MainSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Main" <| do 8 | 9 | it "needs tests" pending 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Server/ApplicationSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Server.ApplicationSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Server.Application" <| do 8 | 9 | it "needs tests" pending 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Server/CommonSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Server.CommonSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Server.Common" <| do 8 | 9 | it "needs tests" pending 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Server/MainSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Server.MainSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Server.Main" <| do 8 | 9 | it "needs tests" pending 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Server/MiddlewareSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Server.MiddlewareSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Server.Middleware" <| do 8 | 9 | it "needs tests" pending 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Server/RouterSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Server.RouterSpec where 2 | 3 | import Monadoc.Prelude 4 | import qualified Monadoc.Server.Router as Router 5 | import qualified Monadoc.Type.Config as Config 6 | import qualified Monadoc.Type.Route as Route 7 | import Test.Hspec 8 | 9 | spec :: Spec 10 | spec = describe "Monadoc.Server.Router" <| do 11 | 12 | describe "parseRoute" <| do 13 | 14 | it "works" <| do 15 | Router.parseRoute "GET" [] `shouldBe` Just Route.Index 16 | 17 | describe "renderAbsoluteRoute" <| do 18 | 19 | it "works" <| do 20 | Router.renderAbsoluteRoute Config.test Route.Index 21 | `shouldBe` "http://monadoc.test:4444/" 22 | 23 | describe "renderRelativeRoute" <| do 24 | 25 | it "works" <| do 26 | Router.renderRelativeRoute Route.Index `shouldBe` "/" 27 | -------------------------------------------------------------------------------- /src/test/Monadoc/Server/SettingsSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Server.SettingsSpec where 2 | 3 | import qualified Monadoc 4 | import Monadoc.Prelude 5 | import qualified Monadoc.Server.Settings as Settings 6 | import qualified Monadoc.Type.Config as Config 7 | import qualified Network.Wai.Handler.Warp as Warp 8 | import Test.Hspec 9 | 10 | spec :: Spec 11 | spec = describe "Monadoc.Server.Settings" <| do 12 | 13 | describe "fromConfig" <| do 14 | 15 | it "sets the host" <| do 16 | let cfg = Config.test { Config.host = "1.2.3.4" } 17 | ctx <- Monadoc.configToContext cfg 18 | let settings = Settings.fromContext ctx 19 | Warp.getHost settings `shouldBe` Config.host cfg 20 | 21 | it "sets the port" <| do 22 | ctx <- Monadoc.configToContext Config.test 23 | let settings = Settings.fromContext ctx 24 | Warp.getPort settings `shouldBe` Config.port Config.test 25 | -------------------------------------------------------------------------------- /src/test/Monadoc/Server/TemplateSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Server.TemplateSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Server.Template" <| do 8 | 9 | it "needs tests" pending 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/AppSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.AppSpec where 2 | 3 | import qualified Control.Monad.IO.Class as IO 4 | import qualified Database.SQLite.Simple as Sql 5 | import qualified Monadoc 6 | import Monadoc.Prelude 7 | import qualified Monadoc.Type.App as App 8 | import qualified Monadoc.Type.Config as Config 9 | import Test.Hspec 10 | 11 | spec :: Spec 12 | spec = describe "Monadoc.Type.App" <| do 13 | 14 | describe "run" <| do 15 | 16 | it "works" <| do 17 | ctx <- Monadoc.configToContext Config.test 18 | App.run ctx (pure ()) `shouldReturn` () 19 | 20 | describe "withConnection" <| do 21 | 22 | it "works" <| do 23 | ctx <- Monadoc.configToContext Config.test 24 | result <- App.run ctx <<< App.withConnection <| \connection -> 25 | IO.liftIO <| Sql.query_ connection "select 1" 26 | result `shouldBe` [Sql.Only (1 :: Int)] 27 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/BinarySpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.BinarySpec where 2 | 3 | import qualified Data.ByteString as ByteString 4 | import qualified Database.SQLite.Simple as Sql 5 | import qualified Database.SQLite.Simple.FromField as Sql 6 | import qualified Database.SQLite.Simple.Internal as Sql 7 | import qualified Database.SQLite.Simple.ToField as Sql 8 | import Monadoc.Prelude 9 | import qualified Monadoc.Type.Binary as Monadoc 10 | import Test.Hspec 11 | 12 | spec :: Spec 13 | spec = describe "Monadoc.Type.Binary" <| do 14 | 15 | describe "fromField" <| do 16 | 17 | it "converts from a blob" <| do 18 | let 19 | byteString = ByteString.pack [0x00, 0x01, 0x0f, 0x10, 0xf0, 0xff] 20 | field = Sql.Field (Sql.SQLBlob byteString) 0 21 | binary = Monadoc.fromByteString byteString 22 | Sql.fromField field `shouldBe` pure binary 23 | 24 | describe "toField" <| do 25 | 26 | it "converts to a blob" <| do 27 | let 28 | byteString = ByteString.pack [0x00, 0x01, 0x0f, 0x10, 0xf0, 0xff] 29 | binary = Monadoc.fromByteString byteString 30 | sqlData = Sql.SQLBlob byteString 31 | Sql.toField binary `shouldBe` sqlData 32 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/Cabal/ModuleNameSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Cabal.ModuleNameSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Type.Cabal.ModuleName" <| do 8 | 9 | it "needs tests" pending 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/Cabal/PackageNameSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Cabal.PackageNameSpec where 2 | 3 | import qualified Data.Maybe as Maybe 4 | import Monadoc.Prelude 5 | import qualified Monadoc.Type.Cabal.PackageName as PackageName 6 | import Test.Hspec 7 | 8 | spec :: Spec 9 | spec = describe "Monadoc.Type.Cabal.PackageName" <| do 10 | 11 | describe "fromString" <| do 12 | 13 | it "works" <| do 14 | PackageName.fromString "some-package" `shouldSatisfy` Maybe.isJust 15 | 16 | describe "toString" <| do 17 | 18 | it "works" <| do 19 | let string = "some-package" 20 | Just packageName <- pure <| PackageName.fromString string 21 | PackageName.toString packageName `shouldBe` string 22 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/Cabal/VersionRangeSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Cabal.VersionRangeSpec where 2 | 3 | import qualified Data.Maybe as Maybe 4 | import Monadoc.Prelude 5 | import qualified Monadoc.Type.Cabal.VersionRange as VersionRange 6 | import Test.Hspec 7 | 8 | spec :: Spec 9 | spec = describe "Monadoc.Type.Cabal.VersionRange" <| do 10 | 11 | describe "fromString" <| do 12 | 13 | it "works" <| do 14 | VersionRange.fromString "> 0" `shouldSatisfy` Maybe.isJust 15 | 16 | describe "toString" <| do 17 | 18 | it "works" <| do 19 | let string = ">0" 20 | Just versionRange <- pure <| VersionRange.fromString string 21 | VersionRange.toString versionRange `shouldBe` string 22 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/Cabal/VersionSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Cabal.VersionSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Type.Cabal.Version" <| do 8 | 9 | it "needs tests" pending 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/ConfigResultSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.ConfigResultSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Type.ConfigResult" <| do 8 | 9 | pure () 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/ConfigSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.ConfigSpec where 2 | 3 | import Monadoc.Prelude 4 | import qualified Monadoc.Type.Config as Config 5 | import Test.Hspec 6 | 7 | spec :: Spec 8 | spec = describe "Monadoc.Type.Config" <| do 9 | 10 | describe "initial" <| do 11 | 12 | it "does not show the help" <| do 13 | Config.help Config.initial `shouldBe` False 14 | 15 | it "does not show the version" <| do 16 | Config.version Config.initial `shouldBe` False 17 | 18 | it "does not bind all hosts" <| do 19 | Config.host Config.initial `shouldBe` "127.0.0.1" 20 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/ContextSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.ContextSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Type.Context" <| do 8 | 9 | pure () 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/EtagSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.EtagSpec where 2 | 3 | import qualified Data.Text as Text 4 | import qualified Database.SQLite.Simple as Sql 5 | import qualified Database.SQLite.Simple.FromField as Sql 6 | import qualified Database.SQLite.Simple.Internal as Sql 7 | import qualified Database.SQLite.Simple.Ok as Sql 8 | import qualified Database.SQLite.Simple.ToField as Sql 9 | import Monadoc.Prelude 10 | import qualified Monadoc.Type.Etag as Etag 11 | import Test.Hspec 12 | 13 | spec :: Spec 14 | spec = describe "Monadoc.Type.Etag" <| do 15 | 16 | describe "fromField" <| do 17 | 18 | it "parses an ETag" <| do 19 | let 20 | byteString = "\"0123456789aBcDeF\"" 21 | field = Sql.Field (Sql.SQLText <<< Text.pack <| show byteString) 0 22 | etag = Etag.fromByteString byteString 23 | Sql.fromField field `shouldBe` pure etag 24 | 25 | it "fails to parse an invalid ETag" <| do 26 | let field = Sql.Field (Sql.SQLText "not valid") 0 27 | Sql.fromField field `shouldBe` (Sql.Errors [] :: Sql.Ok Etag.Etag) 28 | 29 | describe "toField" <| do 30 | 31 | it "renders an ETag" <| do 32 | let 33 | byteString = "\"0123456789aBcDeF\"" 34 | etag = Etag.fromByteString byteString 35 | sqlData = Sql.SQLText <<< Text.pack <| show byteString 36 | Sql.toField etag `shouldBe` sqlData 37 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/GitHub/LoginSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.GitHub.LoginSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Type.GitHub.Login" <| do 8 | 9 | pure () 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/GitHub/UserIdSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.GitHub.UserIdSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Type.GitHub.UserId" <| do 8 | 9 | pure () 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/GitHub/UserSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.GitHub.UserSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Type.GitHub.User" <| do 8 | 9 | it "needs tests" pending 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/GuidSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.GuidSpec where 2 | 3 | import qualified Data.UUID as Uuid 4 | import Monadoc.Prelude 5 | import qualified Monadoc.Type.Guid as Guid 6 | import qualified System.Random as Random 7 | import Test.Hspec 8 | 9 | spec :: Spec 10 | spec = describe "Monadoc.Type.Guid" <| do 11 | 12 | describe "random" <| do 13 | 14 | it "generates a random GUID" <| do 15 | let 16 | gen = Random.mkStdGen 0 17 | (guid, _) = Guid.random gen 18 | uuid <- maybe (fail "invalid UUID") pure 19 | <| Uuid.fromString "fffd04bd-0ede-42e0-8088-a28c5fba9949" 20 | guid `shouldBe` Guid.fromUuid uuid 21 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/MigrationMismatchSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.MigrationMismatchSpec where 2 | 3 | import qualified Control.Monad.Catch as Exception 4 | import qualified Data.Time.Clock.POSIX as Time 5 | import Monadoc.Prelude 6 | import qualified Monadoc.Type.MigrationMismatch as MigrationMismatch 7 | import qualified Monadoc.Type.Sha256 as Sha256 8 | import qualified Monadoc.Type.Timestamp as Timestamp 9 | import Test.Hspec 10 | 11 | spec :: Spec 12 | spec = describe "Monadoc.Type.MigrationMismatch" <| do 13 | 14 | describe "displayException" <| do 15 | 16 | it "looks nice" <| do 17 | expected <- replicate 64 '0' |> read |> maybe 18 | (fail "invalid digest") 19 | (Sha256.fromDigest >>> pure) 20 | actual <- replicate 64 '1' |> read |> maybe 21 | (fail "invalid digest") 22 | (Sha256.fromDigest >>> pure) 23 | let 24 | migrationMismatch = MigrationMismatch.MigrationMismatch 25 | { MigrationMismatch.actual = actual 26 | , MigrationMismatch.expected = expected 27 | , MigrationMismatch.timestamp = Timestamp.fromUtcTime 28 | <| Time.posixSecondsToUTCTime 0 29 | } 30 | string = fold 31 | [ "migration 1970-01-01 00:00:00 UTC expected " 32 | , replicate 64 '0' 33 | , " but got " 34 | , replicate 64 '1' 35 | ] 36 | Exception.displayException migrationMismatch `shouldBe` string 37 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/MigrationSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.MigrationSpec where 2 | 3 | import qualified Data.Time.Clock.POSIX as Time 4 | import qualified Database.SQLite.Simple as Sql 5 | import Monadoc.Prelude 6 | import qualified Monadoc.Type.Migration as Migration 7 | import qualified Monadoc.Type.Sha256 as Sha256 8 | import qualified Monadoc.Type.Timestamp as Timestamp 9 | import Test.Hspec 10 | 11 | spec :: Spec 12 | spec = describe "Monadoc.Type.Migration" <| do 13 | 14 | describe "sha256" <| do 15 | 16 | it "returns the digest of the query" <| do 17 | let 18 | migration = Migration.Migration 19 | { Migration.query = "" 20 | , Migration.timestamp = Timestamp.fromUtcTime 21 | <| Time.posixSecondsToUTCTime 0 22 | } 23 | expected <- 24 | read "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" 25 | |> maybe (fail "invalid digest") (Sha256.fromDigest >>> pure) 26 | Migration.sha256 migration `shouldBe` expected 27 | 28 | describe "toRow" <| do 29 | 30 | it "converts into a SQL row" <| do 31 | let 32 | migration = Migration.Migration 33 | { Migration.query = "" 34 | , Migration.timestamp = Timestamp.fromUtcTime 35 | <| Time.posixSecondsToUTCTime 0 36 | } 37 | row = 38 | [ Sql.SQLText "1970-01-01T00:00:00.000Z" 39 | , Sql.SQLText 40 | "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" 41 | ] 42 | Sql.toRow migration `shouldBe` row 43 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/NotFoundExceptionSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.NotFoundExceptionSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Type.NotFoundException" <| do 8 | 9 | pure () 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/PathSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.PathSpec where 2 | 3 | import Monadoc.Prelude 4 | import qualified Monadoc.Type.Path as Path 5 | import Test.Hspec 6 | 7 | spec :: Spec 8 | spec = describe "Monadoc.Type.Path" <| do 9 | 10 | describe "fromFilePath" <| do 11 | 12 | it "treats forward and backward slashes the same" <| do 13 | Path.fromFilePath "a/b" `shouldBe` Path.fromFilePath "a\\b" 14 | 15 | describe "toFilePath" <| do 16 | 17 | it "uses forward slashes" <| do 18 | Path.toFilePath (Path.fromFilePath "a\\b") `shouldBe` "a/b" 19 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/RevisionSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.RevisionSpec where 2 | 3 | import Monadoc.Prelude 4 | import qualified Monadoc.Type.Revision as Revision 5 | import Test.Hspec 6 | 7 | spec :: Spec 8 | spec = describe "Monadoc.Type.Revision" <| do 9 | 10 | describe "increment" <| do 11 | 12 | it "increases by one" <| do 13 | Revision.increment Revision.zero `shouldBe` Revision.fromWord 1 14 | 15 | describe "toString" <| do 16 | 17 | it "renders just the number" <| do 18 | Revision.toString Revision.zero `shouldBe` "0" 19 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/RouteSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.RouteSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Type.Route" <| do 8 | 9 | pure () 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/ServiceSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.ServiceSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Type.Service" <| do 8 | 9 | pure () 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/Sha256Spec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.Sha256Spec where 2 | 3 | import qualified Crypto.Hash as Crypto 4 | import qualified Data.ByteString as ByteString 5 | import qualified Database.SQLite.Simple as Sql 6 | import qualified Database.SQLite.Simple.FromField as Sql 7 | import qualified Database.SQLite.Simple.Internal as Sql 8 | import qualified Database.SQLite.Simple.Ok as Sql 9 | import qualified Database.SQLite.Simple.ToField as Sql 10 | import Monadoc.Prelude 11 | import qualified Monadoc.Type.Sha256 as Sha256 12 | import Test.Hspec 13 | 14 | spec :: Spec 15 | spec = describe "Monadoc.Type.Sha256" <| do 16 | 17 | describe "fromField" <| do 18 | 19 | it "parses a SHA-256 digest" <| do 20 | let 21 | field = Sql.Field 22 | (Sql.SQLText 23 | "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" 24 | ) 25 | 0 26 | sha256 = Sha256.fromDigest <| Crypto.hash ByteString.empty 27 | Sql.fromField field `shouldBe` pure sha256 28 | 29 | it "fails to parse an invalid SHA-256 digest" <| do 30 | let field = Sql.Field (Sql.SQLText "not valid") 0 31 | Sql.fromField field `shouldBe` (Sql.Errors [] :: Sql.Ok Sha256.Sha256) 32 | 33 | describe "toField" <| do 34 | 35 | it "renders a SHA-256 digest" <| do 36 | let 37 | sha256 = Sha256.fromDigest <| Crypto.hash ByteString.empty 38 | sqlData = Sql.SQLText 39 | "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" 40 | Sql.toField sha256 `shouldBe` sqlData 41 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/SizeSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.SizeSpec where 2 | 3 | import qualified Database.SQLite.Simple as Sql 4 | import qualified Database.SQLite.Simple.FromField as Sql 5 | import qualified Database.SQLite.Simple.Internal as Sql 6 | import qualified Database.SQLite.Simple.ToField as Sql 7 | import Monadoc.Prelude 8 | import qualified Monadoc.Type.Size as Size 9 | import Test.Hspec 10 | 11 | spec :: Spec 12 | spec = describe "Monadoc.Type.Size" <| do 13 | 14 | describe "fromField" <| do 15 | 16 | it "converts from an integer" <| do 17 | let 18 | field = Sql.Field (Sql.SQLInteger 123) 0 19 | size = Size.fromInt 123 20 | Sql.fromField field `shouldBe` pure size 21 | 22 | describe "toField" <| do 23 | 24 | it "converts to an integer" <| do 25 | let 26 | size = Size.fromInt 123 27 | sqlData = Sql.SQLInteger 123 28 | Sql.toField size `shouldBe` sqlData 29 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/TestExceptionSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.TestExceptionSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Type.TestException" <| do 8 | 9 | pure () 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/TimestampSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.TimestampSpec where 2 | 3 | import qualified Database.SQLite.Simple as Sql 4 | import qualified Database.SQLite.Simple.FromField as Sql 5 | import qualified Database.SQLite.Simple.Internal as Sql 6 | import qualified Database.SQLite.Simple.Ok as Sql 7 | import qualified Database.SQLite.Simple.ToField as Sql 8 | import Monadoc.Prelude 9 | import qualified Monadoc.Type.Timestamp as Timestamp 10 | import qualified Monadoc.Utility.Time as Time 11 | import Test.Hspec 12 | 13 | spec :: Spec 14 | spec = describe "Monadoc.Type.Timestamp" <| do 15 | 16 | describe "fromField" <| do 17 | 18 | it "parses a timestamp" <| do 19 | let 20 | field = Sql.Field (Sql.SQLText "2001-02-03T04:05:06.007Z") 0 21 | timestamp = Timestamp.fromUtcTime <| Time.utcTime 2001 2 3 4 5 6.007 22 | Sql.fromField field `shouldBe` pure timestamp 23 | 24 | it "fails to parse an invalid timestamp" <| do 25 | let field = Sql.Field (Sql.SQLText "not valid") 0 26 | Sql.fromField field 27 | `shouldBe` (Sql.Errors [] :: Sql.Ok Timestamp.Timestamp) 28 | 29 | describe "toField" <| do 30 | 31 | it "parses a timestamp" <| do 32 | let 33 | timestamp = Timestamp.fromUtcTime <| Time.utcTime 2001 2 3 4 5 6.007 34 | sqlData = Sql.SQLText "2001-02-03T04:05:06.007Z" 35 | Sql.toField timestamp `shouldBe` sqlData 36 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/UrlSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.UrlSpec where 2 | 3 | import qualified Database.SQLite.Simple as Sql 4 | import qualified Database.SQLite.Simple.FromField as Sql 5 | import qualified Database.SQLite.Simple.Internal as Sql 6 | import qualified Database.SQLite.Simple.Ok as Sql 7 | import qualified Database.SQLite.Simple.ToField as Sql 8 | import Monadoc.Prelude 9 | import qualified Monadoc.Type.Url as Url 10 | import qualified Network.URI as Uri 11 | import Test.Hspec 12 | 13 | spec :: Spec 14 | spec = describe "Monadoc.Type.Url" <| do 15 | 16 | describe "fromField" <| do 17 | 18 | it "parses a basic URL" <| do 19 | let 20 | field = Sql.Field (Sql.SQLText "http://monadoc.test") 0 21 | url = Url.fromUri <| Uri.URI 22 | "http:" 23 | (Just (Uri.URIAuth "" "monadoc.test" "")) 24 | "" 25 | "" 26 | "" 27 | Sql.fromField field `shouldBe` pure url 28 | 29 | it "fails to parse an invalid URL" <| do 30 | let field = Sql.Field (Sql.SQLText "not valid") 0 31 | Sql.fromField field `shouldBe` (Sql.Errors [] :: Sql.Ok Url.Url) 32 | 33 | describe "toField" <| do 34 | 35 | it "renders a basic URL" <| do 36 | let 37 | url = Url.fromUri <| Uri.URI 38 | "http:" 39 | (Just (Uri.URIAuth "" "monadoc.test" "")) 40 | "" 41 | "" 42 | "" 43 | sqlData = Sql.SQLText "http://monadoc.test" 44 | Sql.toField url `shouldBe` sqlData 45 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/UserSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.UserSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Type.User" <| do 8 | 9 | it "needs tests" pending 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Type/WithCallStackSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Type.WithCallStackSpec where 2 | 3 | import qualified Control.Monad as Monad 4 | import qualified Control.Monad.Catch as Exception 5 | import qualified Data.Maybe as Maybe 6 | import Monadoc.Prelude 7 | import qualified Monadoc.Type.TestException as TestException 8 | import qualified Monadoc.Type.WithCallStack as WithCallStack 9 | import Test.Hspec 10 | 11 | spec :: Spec 12 | spec = describe "Monadoc.Type.WithCallStack" <| do 13 | 14 | describe "catch" <| do 15 | 16 | it "catches an exception without a call stack" <| do 17 | WithCallStack.catch 18 | (Exception.throwM TestException.TestException) 19 | (`shouldBe` TestException.TestException) 20 | 21 | it "catches an exception with a call stack" <| do 22 | WithCallStack.catch 23 | (WithCallStack.throw TestException.TestException) 24 | (`shouldBe` TestException.TestException) 25 | 26 | describe "throw" <| do 27 | 28 | it "adds a call stack" <| do 29 | WithCallStack.throw TestException.TestException 30 | `shouldThrow` ((== Just TestException.TestException) 31 | <<< Exception.fromException 32 | <<< WithCallStack.value 33 | ) 34 | 35 | describe "withCallStack" <| do 36 | 37 | it "adds a call stack" <| do 38 | let 39 | x :: Maybe TestException.TestException 40 | x = 41 | Monad.join 42 | <<< map (Exception.fromException <<< WithCallStack.value) 43 | <<< Exception.fromException 44 | <<< WithCallStack.withCallStack 45 | <| Exception.toException TestException.TestException 46 | x `shouldSatisfy` Maybe.isJust 47 | 48 | it "does not add two call stacks" <| do 49 | let 50 | x :: Maybe TestException.TestException 51 | x = 52 | Monad.join 53 | <<< map (Exception.fromException <<< WithCallStack.value) 54 | <<< Exception.fromException 55 | <<< WithCallStack.withCallStack 56 | <<< WithCallStack.withCallStack 57 | <| Exception.toException TestException.TestException 58 | x `shouldSatisfy` Maybe.isJust 59 | 60 | -- Testing this is tough because it uses @SomeException@, which doesn't have 61 | -- an @Eq@ instance. Fortunately this behavior is tested by the @catch@ 62 | -- tests. 63 | describe "withoutCallStack" <| pure () 64 | -------------------------------------------------------------------------------- /src/test/Monadoc/Utility/CabalSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Utility.CabalSpec where 2 | 3 | import qualified Data.Either as Either 4 | import Monadoc.Prelude 5 | import qualified Monadoc.Utility.Cabal as Cabal 6 | import Test.Hspec 7 | 8 | spec :: Spec 9 | spec = describe "Monadoc.Utility.Cabal" <| do 10 | 11 | describe "parse" <| do 12 | 13 | it "parses an empty package" <| do 14 | Cabal.parse "name:x\nversion:0" `shouldSatisfy` Either.isRight 15 | 16 | it "fails to parse an invalid package" <| do 17 | Cabal.parse "" `shouldSatisfy` Either.isLeft 18 | -------------------------------------------------------------------------------- /src/test/Monadoc/Utility/ConsoleSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Utility.ConsoleSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Utility.Console" <| do 8 | 9 | it "needs tests" pending 10 | -------------------------------------------------------------------------------- /src/test/Monadoc/Utility/GhcSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Utility.GhcSpec where 2 | 3 | import qualified Data.Either as Either 4 | import qualified GHC.LanguageExtensions.Type as Ext 5 | import Monadoc.Prelude 6 | import qualified Monadoc.Utility.Ghc as Ghc 7 | import Test.Hspec 8 | 9 | spec :: Spec 10 | spec = describe "Monadoc.Utility.Ghc" <| do 11 | 12 | describe "parse" <| do 13 | 14 | it "parses an empty module" <| do 15 | result <- Ghc.parse [] "" "module M where" 16 | result `shouldSatisfy` Either.isRight 17 | 18 | it "fails to parse an invalid module" <| do 19 | result <- Ghc.parse [] "" "module" 20 | result `shouldSatisfy` Either.isLeft 21 | 22 | it "fails without required extension" <| do 23 | result <- Ghc.parse [] "" "x# = ()" 24 | result `shouldSatisfy` Either.isLeft 25 | 26 | it "succeeds with required extension" <| do 27 | result <- Ghc.parse [(True, Ext.MagicHash)] "" "x# = ()" 28 | result `shouldSatisfy` Either.isRight 29 | 30 | it "succeeds with default extension" <| do 31 | result <- Ghc.parse [] "" "data X = X {}" 32 | result `shouldSatisfy` Either.isRight 33 | 34 | it "fails with default extension disabled" <| do 35 | result <- Ghc.parse 36 | [(False, Ext.TraditionalRecordSyntax)] 37 | "" 38 | "data X = X {}" 39 | result `shouldSatisfy` Either.isLeft 40 | 41 | it "works with CPP" <| do 42 | result <- Ghc.parse 43 | [(True, Ext.Cpp)] 44 | "" 45 | "#ifdef NOT_DEFINED\n\ 46 | \invalid# = True\n\ 47 | \#else\n\ 48 | \module M where\n\ 49 | \#endif" 50 | result `shouldSatisfy` Either.isRight 51 | 52 | it "works with CPP pragma" <| do 53 | result <- Ghc.parse [] "" "{-# language CPP #-}\n#" 54 | result `shouldSatisfy` Either.isRight 55 | 56 | it "does not throw impure CPP errors" <| do 57 | result <- Ghc.parse [(True, Ext.Cpp)] "" "#error" 58 | result `shouldSatisfy` Either.isLeft 59 | 60 | it "works with implied extensions" <| do 61 | result <- Ghc.parse 62 | [(True, Ext.RankNTypes)] 63 | "" 64 | "f :: forall a . a -> a\nf a = a" 65 | result `shouldSatisfy` Either.isRight 66 | -------------------------------------------------------------------------------- /src/test/Monadoc/Utility/SqlSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Utility.SqlSpec where 2 | 3 | import qualified Database.SQLite.Simple as Sql 4 | import qualified Database.SQLite.Simple.Internal as Sql 5 | import qualified Database.SQLite.Simple.Ok as Sql 6 | import Monadoc.Prelude 7 | import qualified Monadoc.Utility.Sql as Sql 8 | import Test.Hspec 9 | import qualified Text.Read as Read 10 | 11 | spec :: Spec 12 | spec = describe "Monadoc.Utility.Sql" <| do 13 | 14 | describe "fromFieldVia" <| do 15 | 16 | it "handles success" <| do 17 | let field = Sql.Field (Sql.SQLText "()") 0 18 | Sql.fromFieldVia Read.readMaybe field `shouldBe` Sql.Ok () 19 | 20 | it "handles failure" <| do 21 | let field = Sql.Field (Sql.SQLText "not valid") 0 22 | Sql.fromFieldVia Read.readMaybe field 23 | `shouldBe` (Sql.Errors [] :: Sql.Ok ()) 24 | -------------------------------------------------------------------------------- /src/test/Monadoc/Utility/TimeSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Utility.TimeSpec where 2 | 3 | import qualified Data.Time as Time 4 | import Monadoc.Prelude 5 | import qualified Monadoc.Utility.Time as Time 6 | import Test.Hspec 7 | 8 | spec :: Spec 9 | spec = describe "Monadoc.Utility.Time" <| do 10 | 11 | describe "format" <| do 12 | 13 | it "formats a UTC time" <| do 14 | Time.format "%Y %m %d %H %M %S %3Q" (Time.utcTime 2001 2 3 4 5 6.007) 15 | `shouldBe` "2001 02 03 04 05 06 .007" 16 | 17 | describe "parse" <| do 18 | 19 | it "parses a UTC time" <| do 20 | Time.parse "%Y %m %d %H %M %S %Q" "2001 02 03 04 05 06 .007" 21 | `shouldBe` Just (Time.utcTime 2001 2 3 4 5 6.007) 22 | 23 | it "returns nothing on failure" <| do 24 | Time.parse "%Y" "invalid" `shouldBe` (Nothing :: Maybe Time.UTCTime) 25 | 26 | describe "utcTime" <| do 27 | 28 | it "builds a UTC time" <| do 29 | Time.utcTime 2001 2 3 4 5 6.007 `shouldBe` Time.UTCTime 30 | { Time.utctDay = Time.fromGregorian 2001 2 3 31 | , Time.utctDayTime = Time.timeOfDayToTime Time.TimeOfDay 32 | { Time.todHour = 4 33 | , Time.todMin = 5 34 | , Time.todSec = 6.007 35 | } 36 | } 37 | 38 | it "clamps date values" <| do 39 | Time.utcTime 2001 13 32 0 0 0 `shouldBe` Time.UTCTime 40 | { Time.utctDay = Time.fromGregorian 2001 12 31 41 | , Time.utctDayTime = Time.timeOfDayToTime Time.TimeOfDay 42 | { Time.todHour = 0 43 | , Time.todMin = 0 44 | , Time.todSec = 0 45 | } 46 | } 47 | 48 | it "does not clamp time values" <| do 49 | Time.utcTime 2001 1 1 25 61 61 `shouldBe` Time.UTCTime 50 | { Time.utctDay = Time.fromGregorian 2001 1 1 51 | , Time.utctDayTime = Time.timeOfDayToTime Time.TimeOfDay 52 | { Time.todHour = 25 53 | , Time.todMin = 61 54 | , Time.todSec = 61 55 | } 56 | } 57 | -------------------------------------------------------------------------------- /src/test/Monadoc/Utility/Utf8Spec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Utility.Utf8Spec where 2 | 3 | import qualified Data.ByteString as ByteString 4 | import Monadoc.Prelude 5 | import qualified Monadoc.Utility.Utf8 as Utf8 6 | import Test.Hspec 7 | 8 | spec :: Spec 9 | spec = describe "Monadoc.Utility.Utf8" <| do 10 | 11 | describe "fromString" <| do 12 | 13 | it "encodes UTF-8" <| do 14 | Utf8.fromString "$" `shouldBe` ByteString.pack [0x24] 15 | Utf8.fromString "\xa2" `shouldBe` ByteString.pack [0xc2, 0xa2] 16 | Utf8.fromString "\x20ac" `shouldBe` ByteString.pack [0xe2, 0x82, 0xac] 17 | Utf8.fromString "\x10348" 18 | `shouldBe` ByteString.pack [0xf0, 0x90, 0x8d, 0x88] 19 | 20 | describe "toString " <| do 21 | 22 | it "decodes UTF-8" <| do 23 | Utf8.toString (ByteString.pack [0x24]) `shouldBe` "$" 24 | Utf8.toString (ByteString.pack [0xc2, 0xa2]) `shouldBe` "\xa2" 25 | Utf8.toString (ByteString.pack [0xe2, 0x82, 0xac]) `shouldBe` "\x20ac" 26 | Utf8.toString (ByteString.pack [0xf0, 0x90, 0x8d, 0x88]) 27 | `shouldBe` "\x10348" 28 | 29 | it "replaces invalid bytes" <| do 30 | Utf8.toString (ByteString.pack [0xc0]) `shouldBe` "\xfffd" 31 | -------------------------------------------------------------------------------- /src/test/Monadoc/Worker/MainSpec.hs: -------------------------------------------------------------------------------- 1 | module Monadoc.Worker.MainSpec where 2 | 3 | import Monadoc.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = describe "Monadoc.Worker.Main" <| do 8 | 9 | it "needs tests" pending 10 | -------------------------------------------------------------------------------- /src/test/MonadocSpec.hs: -------------------------------------------------------------------------------- 1 | module MonadocSpec where 2 | 3 | import qualified Monadoc 4 | import Monadoc.Prelude 5 | import qualified Monadoc.Type.Config as Config 6 | import qualified Monadoc.Type.ConfigResult as ConfigResult 7 | import qualified Monadoc.Type.Context as Context 8 | import Test.Hspec 9 | 10 | spec :: Spec 11 | spec = describe "Monadoc" <| do 12 | 13 | describe "argumentsToConfigResult" <| do 14 | 15 | it "returns the default with no arguments" <| do 16 | Monadoc.argumentsToConfigResult "x" [] 17 | `shouldBe` ConfigResult.Success [] Config.initial 18 | 19 | it "shows the help" <| do 20 | Monadoc.argumentsToConfigResult "x" ["--help"] `shouldSatisfy` isExitWith 21 | 22 | it "shows the version" <| do 23 | Monadoc.argumentsToConfigResult "x" ["--version"] 24 | `shouldSatisfy` isExitWith 25 | 26 | it "fails when given disallowed argument" <| do 27 | Monadoc.argumentsToConfigResult "x" ["--help=0"] 28 | `shouldSatisfy` isFailure 29 | 30 | it "warns when given unexpected parameters" <| do 31 | case Monadoc.argumentsToConfigResult "x" ["y"] of 32 | ConfigResult.Success msgs _ -> msgs `shouldSatisfy` present 33 | result -> result `shouldSatisfy` isSuccess 34 | 35 | it "warns when given unknown options" <| do 36 | case Monadoc.argumentsToConfigResult "x" ["-y"] of 37 | ConfigResult.Success msgs _ -> msgs `shouldSatisfy` present 38 | result -> result `shouldSatisfy` isSuccess 39 | 40 | it "sets the port" <| do 41 | case Monadoc.argumentsToConfigResult "x" ["--port=123"] of 42 | ConfigResult.Success _ cfg -> Config.port cfg `shouldBe` 123 43 | result -> result `shouldSatisfy` isSuccess 44 | 45 | describe "configToContext" <| do 46 | 47 | it "works" <| do 48 | ctx <- Monadoc.configToContext Config.test 49 | Context.config ctx `shouldBe` Config.test 50 | 51 | isExitWith :: ConfigResult.ConfigResult -> Bool 52 | isExitWith configResult = case configResult of 53 | ConfigResult.ExitWith _ -> True 54 | _ -> False 55 | 56 | isFailure :: ConfigResult.ConfigResult -> Bool 57 | isFailure configResult = case configResult of 58 | ConfigResult.Failure _ -> True 59 | _ -> False 60 | 61 | isSuccess :: ConfigResult.ConfigResult -> Bool 62 | isSuccess configResult = case configResult of 63 | ConfigResult.Success _ _ -> True 64 | _ -> False 65 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2020-08-16 2 | --------------------------------------------------------------------------------