├── .gitignore ├── CHANGELOG.md ├── README.md ├── app └── Main.hs ├── frontend ├── .gitignore ├── README.md ├── package.json ├── public │ ├── favicon.ico │ ├── index.html │ ├── logo192.png │ ├── logo512.png │ ├── manifest.json │ └── robots.txt ├── src │ ├── Api.ts │ ├── App.css │ ├── App.test.tsx │ ├── App.tsx │ ├── index.css │ ├── index.tsx │ ├── react-app-env.d.ts │ ├── reportWebVitals.ts │ └── setupTests.ts ├── tsconfig.json └── yarn.lock ├── hs-ts.cabal ├── install.sh └── src ├── DevTool.hs ├── DevTool └── Interface.hs └── Web ├── API.hs ├── Json.hs ├── Server.hs └── Server ├── .Static.hs.swp └── Static.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle/ 2 | node_modules/ 3 | build/ 4 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for hs-ts 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Haskell + TypeScript 2 | 3 | This is a simple example for me to base future 4 | projects on which use Haskell + TypeScript. It 5 | provides scaffolding for dealing with cors 6 | requests when using the `yarn start` command, 7 | and has a convenient installation script which 8 | can be expanded upon to move other artifacts of 9 | importance or create file structure which is 10 | important to your particular application. This 11 | does _not_ contain a production grade server 12 | with middlewares you'd want to run in production. 13 | The choices you'll make in constructing that will 14 | probably be specific to the stack you've chosen: 15 | tracing, logging, metrics, etc. 16 | 17 | The only opinionated choices I've made on the 18 | TypeScript side is including `styled-components`. 19 | I'm just going to want to use this every time, so 20 | it makes sense for me to add it into the template. 21 | 22 | I'm generating the TypeScript types with 23 | `aeson-typescript`, but I am not generating 24 | a client. There are a couple options here: 25 | write my own machinery to generate requests using 26 | fetch or something, or use OpenAPI to generate 27 | the typescript instead of using `aeson-typescript`. 28 | Both routes should be explored, but the dependencies 29 | for the OpenAPI client generator were pretty immense 30 | last I checked. 31 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified DevTool 4 | 5 | main :: IO () 6 | main = DevTool.main 7 | -------------------------------------------------------------------------------- /frontend/.gitignore: -------------------------------------------------------------------------------- 1 | # See https://help.github.com/articles/ignoring-files/ for more about ignoring files. 2 | 3 | # dependencies 4 | /node_modules 5 | /.pnp 6 | .pnp.js 7 | 8 | # testing 9 | /coverage 10 | 11 | # production 12 | /build 13 | 14 | # misc 15 | .DS_Store 16 | .env.local 17 | .env.development.local 18 | .env.test.local 19 | .env.production.local 20 | 21 | npm-debug.log* 22 | yarn-debug.log* 23 | yarn-error.log* 24 | -------------------------------------------------------------------------------- /frontend/README.md: -------------------------------------------------------------------------------- 1 | # Getting Started with Create React App 2 | 3 | This project was bootstrapped with [Create React App](https://github.com/facebook/create-react-app). 4 | 5 | ## Available Scripts 6 | 7 | In the project directory, you can run: 8 | 9 | ### `yarn start` 10 | 11 | Runs the app in the development mode.\ 12 | Open [http://localhost:3000](http://localhost:3000) to view it in the browser. 13 | 14 | The page will reload if you make edits.\ 15 | You will also see any lint errors in the console. 16 | 17 | ### `yarn test` 18 | 19 | Launches the test runner in the interactive watch mode.\ 20 | See the section about [running tests](https://facebook.github.io/create-react-app/docs/running-tests) for more information. 21 | 22 | ### `yarn build` 23 | 24 | Builds the app for production to the `build` folder.\ 25 | It correctly bundles React in production mode and optimizes the build for the best performance. 26 | 27 | The build is minified and the filenames include the hashes.\ 28 | Your app is ready to be deployed! 29 | 30 | See the section about [deployment](https://facebook.github.io/create-react-app/docs/deployment) for more information. 31 | 32 | ### `yarn eject` 33 | 34 | **Note: this is a one-way operation. Once you `eject`, you can’t go back!** 35 | 36 | If you aren’t satisfied with the build tool and configuration choices, you can `eject` at any time. This command will remove the single build dependency from your project. 37 | 38 | Instead, it will copy all the configuration files and the transitive dependencies (webpack, Babel, ESLint, etc) right into your project so you have full control over them. All of the commands except `eject` will still work, but they will point to the copied scripts so you can tweak them. At this point you’re on your own. 39 | 40 | You don’t have to ever use `eject`. The curated feature set is suitable for small and middle deployments, and you shouldn’t feel obligated to use this feature. However we understand that this tool wouldn’t be useful if you couldn’t customize it when you are ready for it. 41 | 42 | ## Learn More 43 | 44 | You can learn more in the [Create React App documentation](https://facebook.github.io/create-react-app/docs/getting-started). 45 | 46 | To learn React, check out the [React documentation](https://reactjs.org/). 47 | -------------------------------------------------------------------------------- /frontend/package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "frontend", 3 | "version": "0.1.0", 4 | "private": true, 5 | "dependencies": { 6 | "@testing-library/jest-dom": "^5.11.4", 7 | "@testing-library/react": "^11.1.0", 8 | "@testing-library/user-event": "^12.1.10", 9 | "@types/jest": "^26.0.15", 10 | "@types/node": "^12.0.0", 11 | "@types/react": "^17.0.0", 12 | "@types/react-dom": "^17.0.0", 13 | "@types/styled-components": "^5.1.12", 14 | "react": "^17.0.2", 15 | "react-dom": "^17.0.2", 16 | "react-scripts": "4.0.3", 17 | "styled-components": "^5.3.1", 18 | "typescript": "^4.1.2", 19 | "web-vitals": "^1.0.1" 20 | }, 21 | "scripts": { 22 | "start": "react-scripts start", 23 | "build": "react-scripts build", 24 | "test": "react-scripts test", 25 | "eject": "react-scripts eject" 26 | }, 27 | "eslintConfig": { 28 | "extends": [ 29 | "react-app", 30 | "react-app/jest" 31 | ] 32 | }, 33 | "browserslist": { 34 | "production": [ 35 | ">0.2%", 36 | "not dead", 37 | "not op_mini all" 38 | ], 39 | "development": [ 40 | "last 1 chrome version", 41 | "last 1 firefox version", 42 | "last 1 safari version" 43 | ] 44 | } 45 | } 46 | -------------------------------------------------------------------------------- /frontend/public/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/SamuelSchlesinger/hs-ts/81dc8d1349260196faa500f9c16178fa9610a6ce/frontend/public/favicon.ico -------------------------------------------------------------------------------- /frontend/public/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 12 | 13 | 17 | 18 | 27 | React App 28 | 29 | 30 | 31 |
32 | 42 | 43 | 44 | -------------------------------------------------------------------------------- /frontend/public/logo192.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/SamuelSchlesinger/hs-ts/81dc8d1349260196faa500f9c16178fa9610a6ce/frontend/public/logo192.png -------------------------------------------------------------------------------- /frontend/public/logo512.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/SamuelSchlesinger/hs-ts/81dc8d1349260196faa500f9c16178fa9610a6ce/frontend/public/logo512.png -------------------------------------------------------------------------------- /frontend/public/manifest.json: -------------------------------------------------------------------------------- 1 | { 2 | "short_name": "React App", 3 | "name": "Create React App Sample", 4 | "icons": [ 5 | { 6 | "src": "favicon.ico", 7 | "sizes": "64x64 32x32 24x24 16x16", 8 | "type": "image/x-icon" 9 | }, 10 | { 11 | "src": "logo192.png", 12 | "type": "image/png", 13 | "sizes": "192x192" 14 | }, 15 | { 16 | "src": "logo512.png", 17 | "type": "image/png", 18 | "sizes": "512x512" 19 | } 20 | ], 21 | "start_url": ".", 22 | "display": "standalone", 23 | "theme_color": "#000000", 24 | "background_color": "#ffffff" 25 | } 26 | -------------------------------------------------------------------------------- /frontend/public/robots.txt: -------------------------------------------------------------------------------- 1 | # https://www.robotstxt.org/robotstxt.html 2 | User-agent: * 3 | Disallow: 4 | -------------------------------------------------------------------------------- /frontend/src/Api.ts: -------------------------------------------------------------------------------- 1 | export interface IExampleRequest { 2 | someField: string; 3 | } 4 | 5 | export interface IExampleResponse { 6 | anotherField: string; 7 | } 8 | 9 | export type ExampleRequest = IExampleRequest; 10 | 11 | export type ExampleResponse = IExampleResponse; 12 | -------------------------------------------------------------------------------- /frontend/src/App.css: -------------------------------------------------------------------------------- 1 | .App { 2 | text-align: center; 3 | } 4 | -------------------------------------------------------------------------------- /frontend/src/App.test.tsx: -------------------------------------------------------------------------------- 1 | import React from 'react'; 2 | import { render, screen } from '@testing-library/react'; 3 | import App from './App'; 4 | 5 | test('renders learn react link', () => { 6 | render(); 7 | const linkElement = screen.getByText(/learn react/i); 8 | expect(linkElement).toBeInTheDocument(); 9 | }); 10 | -------------------------------------------------------------------------------- /frontend/src/App.tsx: -------------------------------------------------------------------------------- 1 | import React from 'react'; 2 | import './App.css'; 3 | import { ExampleRequest, ExampleResponse } from './Api.js'; 4 | import styled from 'styled-components'; 5 | 6 | function exampleEndpoint(exampleRequest: ExampleRequest): Promise { 7 | return fetch('http://localhost:3001/example', 8 | { method: 'POST' 9 | , mode: 'cors' 10 | , cache: 'no-cache' 11 | , credentials: 'omit' 12 | , headers: { 13 | 'Content-Type': 'application/json' 14 | } 15 | , redirect: 'follow' 16 | , referrerPolicy: 'no-referrer' 17 | , body: JSON.stringify(exampleRequest) 18 | } 19 | ).then((r) => r.json()) 20 | } 21 | 22 | const AppContainer = styled.div` 23 | text-align: center; 24 | width: 100% 25 | height: 100% 26 | min-height: 100% 27 | ` 28 | 29 | function ifThenElse(b:boolean, x:X, y:X): X { 30 | if (b) { 31 | return x; 32 | } else { 33 | return y; 34 | }} 35 | 36 | function ExampleForm(props: { input: string, output: string | null, onInputChange: (e:React.ChangeEvent) => void }) { 37 | return ( 38 |
39 | 40 |

Amazing output: { props.output }

41 |
42 | ) 43 | } 44 | 45 | function App() { 46 | const [input, setInput] = React.useState(""); 47 | const [output, setOutput] = React.useState("") 48 | React.useEffect(() => 49 | { const setEm = async () => 50 | { const x = await exampleEndpoint({someField: input}); 51 | setOutput((_o) => x.anotherField); 52 | } 53 | setEm(); 54 | } 55 | , [input]); 56 | const onInputChange = (e: React.ChangeEvent) => { 57 | setInput((_i) => e.target.value); 58 | }; 59 | return ( 60 | 61 |

Haskell + TypeScript Example

62 | 63 | 64 | ); 65 | } 66 | 67 | export default App; 68 | -------------------------------------------------------------------------------- /frontend/src/index.css: -------------------------------------------------------------------------------- 1 | body { 2 | margin: 0; 3 | font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', 'Roboto', 'Oxygen', 4 | 'Ubuntu', 'Cantarell', 'Fira Sans', 'Droid Sans', 'Helvetica Neue', 5 | sans-serif; 6 | -webkit-font-smoothing: antialiased; 7 | -moz-osx-font-smoothing: grayscale; 8 | } 9 | 10 | code { 11 | font-family: source-code-pro, Menlo, Monaco, Consolas, 'Courier New', 12 | monospace; 13 | } 14 | -------------------------------------------------------------------------------- /frontend/src/index.tsx: -------------------------------------------------------------------------------- 1 | import React from 'react'; 2 | import ReactDOM from 'react-dom'; 3 | import './index.css'; 4 | import App from './App'; 5 | import reportWebVitals from './reportWebVitals'; 6 | 7 | ReactDOM.render( 8 | 9 | 10 | , 11 | document.getElementById('root') 12 | ); 13 | 14 | // If you want to start measuring performance in your app, pass a function 15 | // to log results (for example: reportWebVitals(console.log)) 16 | // or send to an analytics endpoint. Learn more: https://bit.ly/CRA-vitals 17 | reportWebVitals(); 18 | -------------------------------------------------------------------------------- /frontend/src/react-app-env.d.ts: -------------------------------------------------------------------------------- 1 | /// 2 | -------------------------------------------------------------------------------- /frontend/src/reportWebVitals.ts: -------------------------------------------------------------------------------- 1 | import { ReportHandler } from 'web-vitals'; 2 | 3 | const reportWebVitals = (onPerfEntry?: ReportHandler) => { 4 | if (onPerfEntry && onPerfEntry instanceof Function) { 5 | import('web-vitals').then(({ getCLS, getFID, getFCP, getLCP, getTTFB }) => { 6 | getCLS(onPerfEntry); 7 | getFID(onPerfEntry); 8 | getFCP(onPerfEntry); 9 | getLCP(onPerfEntry); 10 | getTTFB(onPerfEntry); 11 | }); 12 | } 13 | }; 14 | 15 | export default reportWebVitals; 16 | -------------------------------------------------------------------------------- /frontend/src/setupTests.ts: -------------------------------------------------------------------------------- 1 | // jest-dom adds custom jest matchers for asserting on DOM nodes. 2 | // allows you to do things like: 3 | // expect(element).toHaveTextContent(/react/i) 4 | // learn more: https://github.com/testing-library/jest-dom 5 | import '@testing-library/jest-dom'; 6 | -------------------------------------------------------------------------------- /frontend/tsconfig.json: -------------------------------------------------------------------------------- 1 | { 2 | "compilerOptions": { 3 | "target": "es5", 4 | "lib": [ 5 | "dom", 6 | "dom.iterable", 7 | "esnext" 8 | ], 9 | "allowJs": true, 10 | "skipLibCheck": true, 11 | "esModuleInterop": true, 12 | "allowSyntheticDefaultImports": true, 13 | "strict": true, 14 | "forceConsistentCasingInFileNames": true, 15 | "noFallthroughCasesInSwitch": true, 16 | "module": "esnext", 17 | "moduleResolution": "node", 18 | "resolveJsonModule": true, 19 | "isolatedModules": true, 20 | "noEmit": true, 21 | "jsx": "react-jsx" 22 | }, 23 | "include": [ 24 | "src" 25 | ] 26 | } 27 | -------------------------------------------------------------------------------- /hs-ts.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: hs-ts 3 | version: 0.1.0.0 4 | author: Samuel Schlesinger 5 | maintainer: samuel@simspace.com 6 | extra-source-files: CHANGELOG.md, frontend/build/static/js/*.js, frontend/build/static/css/*.css, frontend/build/*.ico, frontend/build/index.html, frontend/build/*.png, frontend/build/*.txt 7 | 8 | library 9 | exposed-modules: DevTool, Web.API, Web.Server, DevTool.Interface, Web.Json, Web.Server.Static 10 | build-depends: 11 | aeson >=1.5 && <2, 12 | aeson-typescript >=0.3 && <1, 13 | base >=4.4 && <5, 14 | bytestring >=0.10 && <1, 15 | containers >=0.6 && <1, 16 | directory >=1.3 && <2, 17 | file-path-th >=0.1 && <0.2, 18 | filepath >=1.4 && <1.5, 19 | http-media >=0.8 && <0.9, 20 | optparse-applicative >=0.16 && <1, 21 | servant >=0.18 && <0.19, 22 | servant-server >=0.18 && <0.19, 23 | sop-core >=0.5 && <1, 24 | text >=1.2 && <2, 25 | time >=1.9 && <2, 26 | transformers >=0.4 && <0.7, 27 | wai >=3.2 && <4, 28 | wai-app-static >=3.1 && <4, 29 | wai-cors >=0.2 && <1, 30 | wai-extra >=3.1 && <4, 31 | warp >=3.3 && <4 32 | hs-source-dirs: src 33 | ghc-options: -Wall -Werror 34 | default-language: Haskell2010 35 | 36 | executable devtool 37 | main-is: Main.hs 38 | build-depends: base ^>=4.14.2.0, hs-ts 39 | hs-source-dirs: app 40 | default-language: Haskell2010 41 | -------------------------------------------------------------------------------- /install.sh: -------------------------------------------------------------------------------- 1 | cabal install --overwrite-policy=always 2 | echo "Built + Installed Haskell artifacts" 3 | devtool typescript > frontend/src/Api.ts 4 | echo "Generated up to date TypeScript types" 5 | cd frontend 6 | yarn build 7 | cd .. 8 | cabal clean 9 | cabal install --overwrite-policy=always 10 | echo "Re-compiled backend with the frontend artifacts embedded within it" 11 | -------------------------------------------------------------------------------- /src/DevTool.hs: -------------------------------------------------------------------------------- 1 | module DevTool where 2 | 3 | import DevTool.Interface (Command(..), runCommand) 4 | import Options.Applicative 5 | 6 | main :: IO () 7 | main = customExecParser ps parser >>= runCommand 8 | where 9 | ps = prefs . mconcat $ 10 | [ disambiguate 11 | , showHelpOnError 12 | , showHelpOnEmpty 13 | , columns 80 14 | ] 15 | 16 | author :: String 17 | author = "TODO: Replace with your name" 18 | 19 | projectName :: String 20 | projectName = "TODO: Replace with your project name" 21 | 22 | currentYear :: String 23 | currentYear = "TODO: Replace with current year" 24 | 25 | parser :: ParserInfo Command 26 | parser = flip info mods . hsubparser . mconcat $ 27 | [ command "typescript" (info parseTypeScript (progDesc "Generate the typescript for the API")) 28 | , command "serve" (info parseServer (progDesc "Run the server")) 29 | ] 30 | where 31 | mods 32 | = header projectName 33 | <> footer 34 | ( "Copyright " 35 | <> currentYear 36 | <> " (c) " 37 | <> author 38 | ) 39 | <> progDesc "Development Tools" 40 | parseTypeScript 41 | = pure TypeScript 42 | parseServer 43 | = Serve <$> portOption 44 | portOption 45 | = option auto 46 | ( long "port" 47 | <> short 'p' 48 | <> metavar "PORT" 49 | <> value 3001 50 | <> help "The port to run the server on" 51 | ) 52 | -------------------------------------------------------------------------------- /src/DevTool/Interface.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | module DevTool.Interface 4 | ( runCommand 5 | , Command(..) 6 | ) where 7 | 8 | import Web.API (renderedTypeScriptTypes, api) 9 | import Web.Server (server) 10 | import qualified Servant (serve) 11 | import Network.Wai.Handler.Warp (run) 12 | import Network.Wai.Middleware.RequestLogger (logStdoutDev) 13 | import Network.Wai.Middleware.Autohead (autohead) 14 | import Network.Wai.Middleware.Cors (cors, simpleCorsResourcePolicy, CorsResourcePolicy(..)) 15 | 16 | data Command = 17 | TypeScript 18 | | Serve Int 19 | 20 | runCommand :: Command -> IO () 21 | runCommand = \case 22 | TypeScript -> typescript 23 | Serve n -> serve n 24 | 25 | typescript :: IO () 26 | typescript = putStrLn renderedTypeScriptTypes 27 | 28 | serve :: Int -> IO () 29 | serve n = run n . middleware $ Servant.serve api server 30 | where 31 | middleware = 32 | logStdoutDev 33 | . autohead 34 | . cors ( const $ Just (simpleCorsResourcePolicy { corsRequestHeaders = ["Content-Type"] }) ) 35 | -------------------------------------------------------------------------------- /src/Web/API.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DerivingVia #-} 5 | {-# LANGUAGE DerivingStrategies #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE DataKinds #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | module Web.API 15 | ( API 16 | , renderedTypeScriptTypes 17 | , typeScriptTypes 18 | , api 19 | , ExampleRequest(..) 20 | , ExampleResponse(..) 21 | ) where 22 | 23 | import Servant.API 24 | import GHC.TypeLits (Symbol) 25 | import Web.Json 26 | import GHC.Generics (Generic) 27 | import Data.Aeson (ToJSON, FromJSON) 28 | import Data.Proxy (Proxy(Proxy)) 29 | import Data.Aeson.TypeScript.TH (deriveTypeScript, TSDeclaration, formatTSDeclarations', FormattingOptions(..), ExportMode(ExportEach), SumTypeFormat(EnumWithType)) 30 | import Data.Aeson.TypeScript.Recursive (getTypeScriptDeclarationsRecursively) 31 | import Network.HTTP.Media.MediaType ((//)) 32 | 33 | renderedTypeScriptTypes :: String 34 | renderedTypeScriptTypes = formatTSDeclarations' typeScriptFormattingOptions typeScriptTypes where 35 | typeScriptFormattingOptions = FormattingOptions 36 | { numIndentSpaces = 2 37 | , interfaceNameModifier = id 38 | , typeNameModifier = id 39 | , exportMode = ExportEach 40 | , typeAlternativesFormat = EnumWithType 41 | } 42 | 43 | typeScriptTypes :: [TSDeclaration] 44 | typeScriptTypes = getTypeScriptDeclarationsRecursively (Proxy @(TypeScriptTypes API)) 45 | 46 | api :: Proxy API 47 | api = Proxy 48 | 49 | type family TypeScriptTypes xs where 50 | TypeScriptTypes EmptyAPI 51 | = () 52 | TypeScriptTypes (NoContentVerb (method :: k)) 53 | = () 54 | TypeScriptTypes ((x :: Symbol) :> y) 55 | = TypeScriptTypes y 56 | TypeScriptTypes (ReqBody' mods contentTypes x :> y) 57 | = ( If (ContainsJSON contentTypes) x () 58 | , TypeScriptTypes y 59 | ) 60 | TypeScriptTypes (xs :<|> ys) 61 | = ( TypeScriptTypes xs 62 | , TypeScriptTypes ys 63 | ) 64 | TypeScriptTypes (UVerb method contentTypes returnTypes) 65 | = If (ContainsJSON contentTypes) (UVerbTypeScript returnTypes) () 66 | TypeScriptTypes (Verb method status contentTypes returnType) 67 | = If (ContainsJSON contentTypes) returnType () 68 | TypeScriptTypes Raw 69 | = () 70 | 71 | type family UVerbTypeScript xs where 72 | UVerbTypeScript (WithStatus n x ': xs) = (x, UVerbTypeScript xs) 73 | UVerbTypeScript (x ': xs) = (x, UVerbTypeScript xs) 74 | 75 | type family ContainsJSON xs where 76 | ContainsJSON '[] = 'False 77 | ContainsJSON (JSON ': xs) = 'True 78 | ContainsJSON (x ': xs) = ContainsJSON xs 79 | 80 | data AllTypes 81 | 82 | instance Accept AllTypes where 83 | contentType _ = "*" // "*" 84 | 85 | instance MimeRender AllTypes () where 86 | mimeRender _ _ = "" 87 | 88 | data ExampleRequest = ExampleRequest 89 | { someField :: String 90 | } 91 | deriving stock (Eq, Ord, Show, Read, Generic) 92 | deriving (ToJSON, FromJSON) via Json ExampleRequest 93 | 94 | data ExampleResponse = ExampleResponse 95 | { anotherField :: String 96 | } 97 | deriving stock (Eq, Ord, Show, Read, Generic) 98 | deriving (ToJSON, FromJSON) via Json ExampleResponse 99 | 100 | type API = 101 | "health" :> GetNoContent 102 | :<|> "example" :> ReqBody '[JSON] ExampleRequest :> Post '[JSON] ExampleResponse 103 | :<|> UVerb 'GET '[AllTypes] '[WithStatus 302 (Headers '[Header "Location" String] ())] 104 | :<|> Raw 105 | 106 | $(deriveTypeScript aesonOptions ''ExampleRequest) 107 | $(deriveTypeScript aesonOptions ''ExampleResponse) 108 | -------------------------------------------------------------------------------- /src/Web/Json.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | module Web.Json where 4 | 5 | import GHC.Generics (Generic, Rep) 6 | import qualified Data.Aeson as Aeson 7 | import Data.Aeson (ToJSON, FromJSON) 8 | 9 | newtype Json a = Json { unJson :: a } 10 | 11 | instance (Generic a, Aeson.GToJSON' Aeson.Encoding Aeson.Zero (Rep a), Aeson.GToJSON' Aeson.Value Aeson.Zero (Rep a)) => ToJSON (Json a) where 12 | toEncoding = Aeson.genericToEncoding aesonOptions . unJson 13 | toJSON = Aeson.genericToJSON aesonOptions . unJson 14 | 15 | instance (Generic a, Aeson.GFromJSON Aeson.Zero (Rep a)) => FromJSON (Json a) where 16 | parseJSON val = Json <$> Aeson.genericParseJSON aesonOptions val 17 | 18 | aesonOptions :: Aeson.Options 19 | aesonOptions = Aeson.defaultOptions 20 | -------------------------------------------------------------------------------- /src/Web/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | {-# LANGUAGE DataKinds #-} 4 | module Web.Server where 5 | 6 | import Web.API 7 | import Web.Server.Static 8 | import Servant 9 | import Data.SOP.BasicFunctors (I(..)) 10 | import WaiAppStatic.Storage.Embedded (mkSettings) 11 | 12 | server :: Server API 13 | server 14 | = health 15 | :<|> example 16 | :<|> redirect 17 | :<|> fileServer 18 | 19 | health :: Handler NoContent 20 | health = 21 | pure NoContent 22 | 23 | type RedirectResponse = WithStatus 302 (Headers '[Header "Location" String] ()) 24 | 25 | redirect :: Handler (Union '[RedirectResponse]) 26 | redirect 27 | = pure 28 | ( inject @(WithStatus 302 (Headers '[Header "Location" String] ())) 29 | (I (WithStatus (addHeader "/index.html" ()))) 30 | ) 31 | 32 | fileServer :: Server Raw 33 | fileServer = serveDirectoryWith $(mkSettings mkEmbedded) where 34 | 35 | example :: ExampleRequest -> Handler ExampleResponse 36 | example exampleRequest = pure $ ExampleResponse 37 | { anotherField = someField exampleRequest <> "!!!" 38 | } 39 | -------------------------------------------------------------------------------- /src/Web/Server/.Static.hs.swp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/SamuelSchlesinger/hs-ts/81dc8d1349260196faa500f9c16178fa9610a6ce/src/Web/Server/.Static.hs.swp -------------------------------------------------------------------------------- /src/Web/Server/Static.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE BlockArguments #-} 5 | module Web.Server.Static where 6 | 7 | import WaiAppStatic.Storage.Embedded (EmbeddableEntry(..)) 8 | import System.Directory (listDirectory, doesDirectoryExist) 9 | import qualified Data.ByteString.Lazy as BS 10 | import Control.Monad.Trans.Writer.CPS (execWriterT, tell, WriterT) 11 | import Control.Monad (forM_) 12 | import Control.Monad.IO.Class (liftIO) 13 | import System.FilePath (splitExtension) 14 | import Data.String (fromString) 15 | import Control.Exception (SomeException, Exception, handle, throwIO) 16 | import System.FilePath.TH (fileRelativeToProject) 17 | 18 | data DetailedException = DetailedException String SomeException 19 | deriving (Show) 20 | 21 | instance Exception DetailedException 22 | 23 | rethrow :: String -> IO a -> IO a 24 | rethrow msg = handle (throwIO . DetailedException msg) 25 | 26 | frontendBuildDirectory :: FilePath 27 | frontendBuildDirectory = $(fileRelativeToProject "frontend/build") <> "/" 28 | 29 | mkEmbedded :: IO [EmbeddableEntry] 30 | mkEmbedded = rethrow frontendBuildDirectory (listDirectory frontendBuildDirectory) >>= execWriterT . go "" where 31 | go :: FilePath -> [FilePath] -> WriterT [EmbeddableEntry] IO () 32 | go base files = forM_ files \file -> do 33 | let directoryToTest = frontendBuildDirectory <> base <> file 34 | liftIO (rethrow directoryToTest $ doesDirectoryExist directoryToTest) >>= \case 35 | True -> do 36 | let newDirectory = frontendBuildDirectory <> base <> file 37 | liftIO (rethrow newDirectory $ listDirectory newDirectory) >>= go (base <> file <> "/") 38 | False -> do 39 | let fileOfInterest = frontendBuildDirectory <> base <> file 40 | contents <- liftIO (rethrow fileOfInterest $ BS.readFile fileOfInterest) 41 | tell 42 | [ EmbeddableEntry 43 | { eLocation = fromString (base <> file) 44 | , eMimeType = 45 | case snd (splitExtension file) of 46 | ".gif" -> "image/gif" 47 | ".html" -> "text/html" 48 | ".json" -> "text/json" 49 | ".jpg" -> "image/jpeg" 50 | ".jpeg" -> "image/jpeg" 51 | ".png" -> "image/png" 52 | ".svg" -> "image/svg+xml" 53 | ".webp" -> "image/webp" 54 | ".avif" -> "image/avif" 55 | ".apng" -> "image/apng" 56 | "" -> "application/octet-stream" 57 | ".txt" -> "text/plain" 58 | ".css" -> "text/css" 59 | ".js" -> "text/javascript" 60 | ".ico" -> "image/x-icon" 61 | ".map" -> "application/json" 62 | x -> error x 63 | , eContent = Left ("", contents) 64 | } 65 | ] 66 | --------------------------------------------------------------------------------