/// Handlers to manipulate uploaded files module MyWebLog.Handlers.Upload open System open System.IO open Giraffe open Microsoft.AspNetCore.Http open Microsoft.Net.Http.Headers open MyWebLog /// Helper functions for this module [] module private Helpers = open Microsoft.AspNetCore.StaticFiles /// A MIME type mapper instance to use when serving files from the database let mimeMap = FileExtensionContentTypeProvider () /// A cache control header that instructs the browser to cache the result for no more than 30 days let cacheForThirtyDays = let hdr = CacheControlHeaderValue() hdr.MaxAge <- Some (TimeSpan.FromDays 30) |> Option.toNullable hdr /// Shorthand for the directory separator let slash = Path.DirectorySeparatorChar /// The base directory where uploads are stored, relative to the executable let uploadDir = Path.Combine ("wwwroot", "upload") /// Determine if the file has been modified since the date/time specified by the If-Modified-Since header let checkModified since (ctx : HttpContext) : HttpHandler option = match ctx.Request.Headers.IfModifiedSince with | it when it.Count < 1 -> None | it when since > DateTime.Parse it[0] -> None | _ -> Some (setStatusCode 304 >=> setBodyFromString "Not Modified") open Microsoft.AspNetCore.Http.Headers /// Derive a MIME type based on the extension of the file let deriveMimeType path = match mimeMap.TryGetContentType path with true, typ -> typ | false, _ -> "application/octet-stream" /// Send a file, caching the response for 30 days let sendFile updatedOn path (data : byte[]) : HttpHandler = fun next ctx -> let headers = ResponseHeaders ctx.Response.Headers headers.ContentType <- (deriveMimeType >> MediaTypeHeaderValue) path headers.CacheControl <- cacheForThirtyDays let stream = new MemoryStream (data) streamData true stream None (Some (DateTimeOffset updatedOn)) next ctx // GET /upload/{web-log-slug}/{**path} let serve (urlParts : string seq) : HttpHandler = fun next ctx -> task { let webLog = ctx.WebLog let parts = (urlParts |> Seq.skip 1 |> Seq.head).Split '/' let slug = Array.head parts if slug = webLog.slug then // Static file middleware will not work in subdirectories; check for an actual file first let fileName = Path.Combine ("wwwroot", (Seq.head urlParts)[1..]) if File.Exists fileName then return! streamFile true fileName None None next ctx else let path = String.Join ('/', Array.skip 1 parts) match! ctx.Data.Upload.FindByPath path webLog.id with | Some upload -> match checkModified upload.updatedOn ctx with | Some threeOhFour -> return! threeOhFour next ctx | None -> return! sendFile upload.updatedOn path upload.data next ctx | None -> return! Error.notFound next ctx else return! Error.notFound next ctx } // ADMIN open System.Text.RegularExpressions open DotLiquid open MyWebLog.ViewModels /// Turn a string into a lowercase URL-safe slug let makeSlug it = ((Regex """\s+""").Replace ((Regex "[^A-z0-9 ]").Replace (it, ""), "-")).ToLowerInvariant () // GET /admin/uploads let list : HttpHandler = requireAccess Author >=> fun next ctx -> task { let webLog = ctx.WebLog let! dbUploads = ctx.Data.Upload.FindByWebLog webLog.id let diskUploads = let path = Path.Combine (uploadDir, webLog.slug) try Directory.EnumerateFiles (path, "*", SearchOption.AllDirectories) |> Seq.map (fun file -> let name = Path.GetFileName file let create = match File.GetCreationTime (Path.Combine (path, file)) with | dt when dt > DateTime.UnixEpoch -> Some dt | _ -> None { DisplayUpload.Id = "" Name = name Path = file.Replace($"{path}{slash}", "").Replace(name, "").Replace (slash, '/') UpdatedOn = create Source = UploadDestination.toString Disk }) |> List.ofSeq with | :? DirectoryNotFoundException -> [] // This is fine | ex -> warn "Upload" ctx $"Encountered {ex.GetType().Name} listing uploads for {path}:\n{ex.Message}" [] let allFiles = dbUploads |> List.map (DisplayUpload.fromUpload webLog Database) |> List.append diskUploads |> List.sortByDescending (fun file -> file.UpdatedOn, file.Path) return! Hash.FromAnonymousObject {| page_title = "Uploaded Files" csrf = ctx.CsrfTokenSet files = allFiles |} |> viewForTheme "admin" "upload-list" next ctx } // GET /admin/upload/new let showNew : HttpHandler = requireAccess Author >=> fun next ctx -> Hash.FromAnonymousObject {| page_title = "Upload a File" csrf = ctx.CsrfTokenSet destination = UploadDestination.toString ctx.WebLog.uploads |} |> viewForTheme "admin" "upload-new" next ctx /// Redirect to the upload list let showUploads : HttpHandler = redirectToGet "admin/uploads" // POST /admin/upload/save let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then let upload = Seq.head ctx.Request.Form.Files let fileName = String.Concat (makeSlug (Path.GetFileNameWithoutExtension upload.FileName), Path.GetExtension(upload.FileName).ToLowerInvariant ()) let localNow = WebLog.localTime ctx.WebLog DateTime.Now let year = localNow.ToString "yyyy" let month = localNow.ToString "MM" let! form = ctx.BindFormAsync () match UploadDestination.parse form.Destination with | Database -> use stream = new MemoryStream () do! upload.CopyToAsync stream let file = { id = UploadId.create () webLogId = ctx.WebLog.id path = Permalink $"{year}/{month}/{fileName}" updatedOn = DateTime.UtcNow data = stream.ToArray () } do! ctx.Data.Upload.Add file | Disk -> let fullPath = Path.Combine (uploadDir, ctx.WebLog.slug, year, month) let _ = Directory.CreateDirectory fullPath use stream = new FileStream (Path.Combine (fullPath, fileName), FileMode.Create) do! upload.CopyToAsync stream do! addMessage ctx { UserMessage.success with Message = $"File uploaded to {form.Destination} successfully" } return! showUploads next ctx else return! RequestErrors.BAD_REQUEST "Bad request; no file present" next ctx } // POST /admin/upload/{id}/delete let deleteFromDb upId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { match! ctx.Data.Upload.Delete (UploadId upId) ctx.WebLog.id with | Ok fileName -> do! addMessage ctx { UserMessage.success with Message = $"{fileName} deleted successfully" } return! showUploads next ctx | Error _ -> return! Error.notFound next ctx } /// Remove a directory tree if it is empty let removeEmptyDirectories (webLog : WebLog) (filePath : string) = let mutable path = Path.GetDirectoryName filePath let mutable finished = false while (not finished) && path > "" do let fullPath = Path.Combine (uploadDir, webLog.slug, path) if Directory.EnumerateFileSystemEntries fullPath |> Seq.isEmpty then Directory.Delete fullPath path <- String.Join(slash, path.Split slash |> Array.rev |> Array.skip 1 |> Array.rev) else finished <- true // POST /admin/upload/delete/{**path} let deleteFromDisk urlParts : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let filePath = urlParts |> Seq.skip 1 |> Seq.head let path = Path.Combine (uploadDir, ctx.WebLog.slug, filePath) if File.Exists path then File.Delete path removeEmptyDirectories ctx.WebLog filePath do! addMessage ctx { UserMessage.success with Message = $"{filePath} deleted successfully" } return! showUploads next ctx else return! Error.notFound next ctx }