^{previewBlock}
{-# START_FILE config/models #-}
StoredFile
name Text
contentType Text
content ByteString
{-# START_FILE config/routes #-}
/ HomeR GET POST
/file/#Int PreviewR GET
/file/#Int/download DownloadR GET
```
The call to `migrateAll` in the "Main.hs" will cause the following to be logged if no file named "database" exists yet.
```
Migrating: CREATE TABLE "stored_file"("id" INTEGER PRIMARY KEY,"name" VARCHAR NOT NULL,"content_type" VARCHAR NOT NULL,"content" BLOB NOT NULL)
[Debug#SQL] "CREATE TABLE \"stored_file\"(\"id\" INTEGER PRIMARY KEY,\"name\" VARCHAR NOT NULL,\"content_type\" VARCHAR NOT NULL,\"content\" BLOB NOT NULL)" [] @(persistent-1.2.3.0:Database.Persist.Sql.Raw ./Database/Persist/Sql/Raw.hs:37:5)
```
## Phase 3: Switching to Persistent Storage
All of the steps needed to access a database have been dealt with. Settings for the backend have been defined in "Config.hs". These are accessed for initialization in "Main.hs" and in calls to runDB through the foundation type's YesodPersist instance. As the database is opened, a model definition defined in "config/models" is used to update the database schema if necessary.
The time has come to exchange our old data access layer for the new one. They are currently running side by side. None of our handlers are importing "Model.hs", so only the old code is accessible. We're going to do this all at once, but there are actually 3 small steps to perform:
* Update routing system to identify stored files by a Persistent identifier rather than an `Int`.
* Update accessor functions to perform database operations.
* Update templates to work with the new `StoredFile` type.
### Updating routing system
We need to update the routing definition specified in "config/routes". It currently uses `Int` values to identify files. Persistent uses abstracted types for this purpose. In the case of our application this type is either `StoredFileId` or `Key StoredFile`.
``` haskell
{-# START_FILE config/routes #-}
-- / HomeR GET POST
-- /file/#Int PreviewR GET
-- /file/#Int/download DownloadR GET
{-hi-}/ HomeR GET POST
/file/#StoredFileId PreviewR GET
/file/#StoredFileId/download DownloadR GET{-/hi-}
```
Our `getPreviewR` and `getDownloadR` handler actions will need to be updated to use the new types:
``` haskell
{-# START_FILE Handler/Download.hs #-}
module Handler.Download where
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Yesod
import Foundation
{-hi-}import Model{-/hi-}
-- getDownloadR :: Int -> Handler TypedContent
{-hi-}getDownloadR :: Key StoredFile -> Handler TypedContent{-/hi-}
getDownloadR ident = do
StoredFile filename contentType bytes <- getById ident
addHeader "Content-Disposition" $ Text.concat
[ "attachment; filename=\"", filename, "\""]
sendResponse (Text.encodeUtf8 contentType, toContent bytes)
{-# START_FILE Handler/Preview.hs #-}
module Handler.Preview where
import Control.Exception hiding (Handler)
import qualified Data.ByteString as SB
import Data.Default
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Text.Blaze
import Yesod
import Yesod.Default.Util
import Foundation
{-hi-}import Model{-/hi-}
-- getPreviewR :: Int -> Handler Html
{-hi-}getPreviewR :: Key StoredFile -> Handler Html{-/hi-}
getPreviewR ident = do
StoredFile filename contentType bytes <- getById ident
defaultLayout $ do
setTitle . toMarkup $ "File Processor - " `Text.append` filename
previewBlock <- liftIO $ preview ident contentType bytes
$(widgetFileNoReload def "preview")
-- preview :: Int -> Text -> SB.ByteString -> IO Widget
{-hi-}preview :: Key StoredFile -> Text -> SB.ByteString -> IO Widget{-/hi-}
preview ident contentType bytes
| "image/" `Text.isPrefixOf` contentType =
return [whamlet||]
| otherwise = do
eText <- try . evaluate $ Text.decodeUtf8 bytes :: IO (Either SomeException Text)
return $ case eText of
Left _ -> errorMessage
Right text -> [whamlet|
#{text}|]
where
errorMessage = [whamlet|Unable to display file contents.|]
```
### Updating accessor functions
Starting with [part 2](https://www.fpcomplete.com/school/advanced-haskell/building-a-file-hosting-service-in-yesod/part%202) of this series we began manipulating our collection of files through a few accessor functions. Every piece of code having to do with storage was contained in the Foundation module. Accessors run in the `Handler` monad for convenient access to the foundation type and so they can short circuit with an HTTP error response if needed.
As you will see, most of these will shrink down to a single line. Having given our foundation type a
YesodPersist instance, we can execute a database query in handler actions with runDB. Read the Database.Persist.Class module's documentation to see which operations can be performed.
#### addFile
We'll start with the `addFile` accessor. Previously this was the most complicated of them, but is now the most simple. Persistent manages automatically incrementing identifiers for us:
``` haskell
addFile :: StoredFile -> Handler ()
-- addFile file = do
-- app <- getYesod
-- liftIO . atomically $ do
-- ident <- getNextId app
-- modifyTVar (tstore app) $ IntMap.insert ident file
{-hi-}addFile file = runDB $ insert_ file{-/hi-}
```
This was the only place where we were calling `getNextId`, so it can be deleted:
``` haskell
-- getNextId :: App -> STM Int
-- getNextId app = do
-- nextId <- readTVar $ tnextId app
-- writeTVar (tnextId app) $ nextId + 1
-- return nextId
```
#### getById
The `getById` accessor is used in `getPreviewR` and `getDownloadR` to retrieve information about a specific file. As with elsewhere, we are now identifying files with a `Key StoredFile` rather than an `Int`.
The interesting thing is that we are able to short circuit with an HTTP 404 response if visitors click on a broken link such as "http://myhost.com/file/987654321".
``` haskell
-- getById :: Int -> Handler StoredFile
-- getById ident = do
-- app <- getYesod
-- store <- liftIO . readTVarIO $ tstore app
-- case IntMap.lookup ident store of
-- Nothing -> notFound
-- Just file -> return file
{-hi-}getById :: Key StoredFile -> Handler StoredFile
getById ident = do
mfile <- runDB $ get ident
case mfile of
Nothing -> notFound
Just file -> return file{-/hi-}
```
#### getList
The `getList` accessor is used by the `getHomeR` route handler to generate a list of hyperlinks to preview pages. The key pieces of information needed are the internal identifier for a file and its name. Previously we returned a tuple, but Persistent has a specific type for this purpose:
``` haskell
-- getList :: Handler [(Int, StoredFile)]
-- getList = do
-- app <- getYesod
-- store <- liftIO . readTVarIO $ tstore app
-- return $ IntMap.toList store
{-hi-}getList :: Handler [Entity StoredFile]
getList = runDB $ selectList [] []{-/hi-}
```
The empty lists given to selectList are used for sorting and filtering. You might sort alphabetically by name with `selectList [] [Asc StoredFileName]`. Use combinators found in the Database.Persist module to specify filter criteria. You can filter out all but .png files with `selectList [StoredFileContentType ==. "image/png"] []`. I recommend experimenting with this.
### Updating templates
Our "Handler/Home.hs" handler module and associated Hamlet template will need to be updated slightly because of changes we made to `getList`:
``` haskell
{-# START_FILE Handler/Home.hs #-}
module Handler.Home where
import Control.Monad.Trans.Resource
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Conduit
import Data.Conduit.Binary
import Data.Default
import Yesod
import Yesod.Default.Util
import Foundation
{-hi-}import Model{-/hi-}
getHomeR :: Handler Html
getHomeR = do
(formWidget, formEncType) <- generateFormPost uploadForm
storedFiles <- getList
defaultLayout $ do
setTitle "File Processor"
$(widgetFileNoReload def "home")
postHomeR :: Handler Html
postHomeR = do
((result, _), _) <- runFormPost uploadForm
case result of
FormSuccess fi -> do
fileBytes <- runResourceT $ fileSource fi $$ sinkLbs
addFile $ StoredFile (fileName fi) (fileContentType fi)
(S.pack . L.unpack $ fileBytes)
_ -> return ()
redirect HomeR
uploadForm :: Html -> MForm Handler (FormResult FileInfo, Widget)
uploadForm = renderDivs $ fileAFormReq "file"
{-# START_FILE templates/home.hamlet #-}
Previously submitted files
$if null storedFiles
No files have been uploaded yet.
$else