server.tri (6747B)
1 !import "prelude" !Local 2 !import "io" !Local 3 !import "http" !Local 4 !import "socket" !Local 5 !import "patterns" !Local 6 !import "arboricx" !Local 7 8 -- --------------------------------------------------------------------------- 9 -- Store layout helpers 10 -- --------------------------------------------------------------------------- 11 12 pathJoin a b = append a (append "/" b) 13 14 objectDir root shard = 15 pathJoin (pathJoin root "objects") shard 16 17 hashShard hash = 18 matchList 19 t 20 (h0 r0 : 21 matchList 22 (pair h0 t) 23 (h1 r1 : 24 matchList 25 (pair h0 (pair h1 t)) 26 (h2 _ : 27 pair h0 (pair h1 (pair h2 t))) 28 r1) 29 r0) 30 hash 31 32 bundleObjectPath root hash = 33 pathJoin 34 (objectDir root (hashShard hash)) 35 (append hash ".arboricx") 36 37 bundleTmpPath root hash time = 38 pathJoin 39 (pathJoin root "tmp") 40 (append hash ".tmp") 41 42 -- --------------------------------------------------------------------------- 43 -- Store initialization 44 -- --------------------------------------------------------------------------- 45 46 ensureDir path = 47 void (createDirectory path) 48 49 ensureStore root = 50 foldl 51 thenIO 52 (pure (ok t t)) 53 [(ensureDir root) 54 (ensureDir (pathJoin root "tmp")) 55 (ensureDir (pathJoin root "objects")) 56 (ensureDir (pathJoin root "aliases")) 57 (ensureDir (pathJoin (pathJoin root "aliases") "names")) 58 (ensureDir (pathJoin (pathJoin root "aliases") "packages")) 59 (ensureDir (pathJoin root "manifests"))] 60 61 -- --------------------------------------------------------------------------- 62 -- Bundle object write 63 -- --------------------------------------------------------------------------- 64 65 putBundleWrite root bundleBytes hash shard tmpPath finalPath = 66 do onOk_ 67 _ <- mapErrIO "createDirectory: " (createDirectory (objectDir root shard)) 68 _ <- mapErrIO "writeBytes: " (writeBytes tmpPath bundleBytes) 69 _ <- mapErrIO "renameFile: " (renameFile tmpPath finalPath) 70 pure (ok hash t) 71 72 putBundleWithHash root bundleBytes time hash = 73 let shard = hashShard hash in 74 let tmpPath = bundleTmpPath root hash time in 75 let finalPath = bundleObjectPath root hash in 76 putBundleWrite root bundleBytes hash shard tmpPath finalPath 77 78 putBundle root bundleBytes = 79 do onOk_ 80 time <- mapErrIO "currentTime: " currentTime 81 hash <- mapErrIO "sha256Hex: " (sha256Hex bundleBytes) 82 savedHash <- mapErrIO "withHash: " (putBundleWithHash root bundleBytes time hash) 83 pure (ok savedHash t) 84 85 -- --------------------------------------------------------------------------- 86 -- Bundle object fetch 87 -- --------------------------------------------------------------------------- 88 89 getBundleByHash root hash = 90 onResult_ (readFile (bundleObjectPath root hash)) 91 (errMsg : pure (err errMsg t)) 92 (bytes : pure (ok bytes t)) 93 94 -- --------------------------------------------------------------------------- 95 -- Route prefix helper 96 -- --------------------------------------------------------------------------- 97 98 stripPrefix_ self input prefix = 99 lazyList 100 (_ : 101 lazyList 102 (_ : just t) 103 (_ _ : nothing) 104 prefix) 105 (ih ir : 106 lazyList 107 (_ : just input) 108 (ph pr : 109 lazyBool 110 (_ : self ir pr) 111 (_ : nothing) 112 (equal? ih ph)) 113 prefix) 114 input 115 116 stripPrefix prefix input = 117 y stripPrefix_ input prefix 118 119 bundleHashPrefix = "/_arboricx/bundle/hash/" 120 bundlePath = "/_arboricx/bundle" 121 healthPath = "/_arboricx/health" 122 bundleContentType = "application/vnd.arboricx.bundle" 123 124 -- --------------------------------------------------------------------------- 125 -- Landing page 126 -- --------------------------------------------------------------------------- 127 128 -- TODO: Let's replace in-line HTML with the ability to read and serve files 129 -- from a public/ folder. 130 131 htmlLandingPage = "<!DOCTYPE html><html><head><meta name='viewport' content='width=device-width, initial-scale=1'><title>Arboricx Server</title></head><body><h1>Arboricx Server</h1><p>Bundle registry</p><p><a href='https://git.eversole.co/James/tricu'>Made with Love (and trees, lots of trees)</a></p></body></html>" 132 133 -- --------------------------------------------------------------------------- 134 -- Registry routes 135 -- --------------------------------------------------------------------------- 136 137 bundleResponse bytes = response 200 bundleContentType bytes 138 139 serveBundleHash root hash = 140 onResult_ (getBundleByHash root hash) 141 (errMsg : pure (errorResponse 404 errMsg)) 142 (bytes : pure (bundleResponse bytes)) 143 144 healthRoute method target = 145 cond 146 [(guard (_ : equal? method "GET") (_ : getHealth)) 147 (guard (_ : true) (_ : pure notFoundResponse))] 148 where getHealth = 149 cond 150 [(guard (_ : equal? target healthPath) (_ : pure (okResponse "OK\n"))) 151 (guard (_ : true) (_ : pure notFoundResponse))] 152 153 putBundleRoute root method target body = 154 cond 155 [(guard (_ : equal? method "POST") (_ : postBundle)) 156 (guard (_ : true) (_ : pure notFoundResponse))] 157 where postBundle = 158 cond 159 [(guard (_ : equal? target bundlePath) (_ : handleUpload)) 160 (guard (_ : true) (_ : pure notFoundResponse))] 161 where handleUpload = 162 onResult_ (putBundle root body) 163 (err : pure (badRequestResponse (append "Upload failed: " err))) 164 (hash : pure (createdResponse hash)) 165 166 getBundleRoute root method target = 167 cond 168 [(guard (_ : equal? method "GET") (_ : getBundle)) 169 (guard (_ : true) (_ : pure notFoundResponse))] 170 where getBundle = 171 lazyMaybe 172 (_ : pure notFoundResponse) 173 (hash : serveBundleHash root hash) 174 (stripPrefix bundleHashPrefix target) 175 176 arboricxRouter root method target headers body = 177 cond 178 [(guard (_ : equal? method "GET") (_ : getRoutes)) 179 (guard (_ : equal? method "POST") (_ : putBundleRoute root method target body)) 180 (guard (_ : true) (_ : pure notFoundResponse))] 181 where getRoutes = 182 cond 183 [(guard (_ : equal? target "/") (_ : pure (htmlResponse htmlLandingPage))) 184 (guard (_ : true) (_ : getBundleOrHealth))] 185 where getBundleOrHealth = 186 lazyMaybe 187 (_ : healthRoute method target) 188 (hash : serveBundleHash root hash) 189 (stripPrefix bundleHashPrefix target) 190 191 -- --------------------------------------------------------------------------- 192 -- Server entrypoint 193 -- --------------------------------------------------------------------------- 194 195 arboricxHandler root = (client peer : 196 httpHandlerIO 197 (method target headers body : 198 arboricxRouter root method target headers body) 199 client 200 peer) 201 202 arboricxServer root addr port = 203 onResult_ (listenSocket addr port 128) 204 (errMsg : pure (err errMsg t)) 205 (server : 206 serveForever server (arboricxHandler root))